In order to manage the errors coming from a particular client I am thinking about having the app send the current error log file to me, perhaps when it starts up.
What would the best way to achieve this in a VB6/XP environment?
Email might be easy but I imagine that could fire off all sorts of anti-virus/firewall protections.
Connecting to a webserver might be better. Would the app still have to open up the Windows firewall in this case?
I'm using XMLHTTP to upload clients error logs like this: http://wqweto.wordpress.com/2011/07/12/vb6-using-wininet-to-post-binary-file/
Private Sub pvPostFile(sUrl As String, sFileName As String, Optional ByVal bAsync As Boolean)
Const STR_BOUNDARY As String = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String
'--- read file
nFile = FreeFile
Open sFileName For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbUnicode)
End If
Close nFile
'--- prepare body
sPostData = "--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
sPostData & vbCrLf & _
"--" & STR_BOUNDARY & "--"
'--- post
With CreateObject("Microsoft.XMLHTTP")
.Open "POST", sUrl, bAsync
.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY
.Send pvToByteArray(sPostData)
End With
End Sub
Private Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbFromUnicode)
End Function
Related
I want to send Image or pdf document in post request, the URL is working fine, but in visual basic I used the below code to send the document using url but It gives me failure response server error .
I have checked URL, it has no issue, but when I tried to implement in vb, in response I get the 500 server error
Dim strFile As String
Dim uploadDocUrl As String
Dim baBuffer() As Byte
Dim sPostData As String
Dim strFile As String
Dim strFileName As String
strFile = "C://Users/Avinashi/Desktop/1.pdf"
uploadDocUrl = "http://api.tally.messaging.bizbrain.in/api/v1/uploadFile"
strFileName = "1.pdf"
nFile = FreeFile
Open strFile For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbUnicode)
End If
Close nFile
sPostData = "--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data;name=""1.pdf""; filename=""" & Mid$(strFile, InStrRev(strFile, "\") + 1) & """" & vbCrLf & _
"Content-Type:multipart/form-data" & vbCrLf & vbCrLf & _
sPostData & vbCrLf & _
"--" & STR_BOUNDARY & "--"
With CreateObject("Microsoft.XMLHTTP")
.Open "POST", uploadDocUrl, bAsync
.SetRequestHeader "Content-Type", "multipart/form-data"
.SetRequestHeader "token", "78bea912b4a5c497b85926bb471fab04"
.Send pvToByteArray(sPostData)
MsgBox (.responseText)
End With
Private Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbUnicode)
End Function
Please see this post for the same issue in bash.
Here is my main code:
loadFile "md5.vbs"
wscript.echo "md5('test') = " & md5("test")
loadFile "sha256.vbs"
wscript.echo "sha256('test') = " & sha256("test")
method = "POST"
app_id = <redacted>
key = "<redacted>"
secret = "<redacted>"
tstamp = datediff("s",#1970/1/1#,dateadd("h",5,now()))
data = "{""data"":{""message"":""hello world""},""name"":""my_event"",""channel"":""test_channel""}"
path = "/apps/" & app_ID & "/events"
query = "body_md5=" & md5(data) & "&auth_version=1.0&auth_key=" & key & "&auth_timestamp=" & tstamp
sig = sha256(method & vbLf & path & vbLf & query & vbLf & secret)
url = "https://api.pusherapp.com" & path & "?" & query & "&auth_signature=" & sig
wscript.echo url
dim xmlhttp
set xmlhttp = Createobject("MSXML2.ServerXMLHTTP")
xmlhttp.Open method,url,false
xmlhttp.setRequestHeader "Content-Type", "application/json"
xmlhttp.send data
WScript.echo xmlhttp.responsetext
Set xmlhttp = nothing
md5.vbs can be found here and sha256.vbs here.
I get this error:
Invalid signature: you should have sent HmacSHA256Hex("POST\n/apps/(redacted)/events\nauth_key=(redacted)&auth_timestamp=1471291494&auth_version=1.0&body_md5=(redacted)", your_secret_key), but you sent "(redacted)"
(code edits: Added secret to sig, changed crlf to lf)
I have a function that pings computers from an excel list and gets the ping value of them.
While the script was running, the excel was completely unresponsive. I could fix this with DoEvents, this made it a bit more responsive.
However, the problem starts when the function gets to an offline computer. While it waits for the response of the offline PC, Excel freezes again and the script does not jump to the next PC until it gets the "timeout" from the actual one.
As the default ping timeout value is 4000ms, if I have 100 computers in my list, and 50 of them are turned off, that means I have to wait an extra 3,3 minutes for the script to finish, and also blocks the entire Excel, making it unusable for the duration.
My question is, if is there any way to make this faster or more responsive or smarter?
The actual code:
Function:
Function sPing(sHost) As String
Dim oPing As Object, oRetStatus As Object
Set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & sHost & "'")
DoEvents
For Each oRetStatus In oPing
DoEvents
If IsNull(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
sPing = "timeout" 'oRetStatus.StatusCode <- error code
Else
sPing = sPing & vbTab & oRetStatus.ResponseTime
End If
Next
End Function
Main:
Sub pingall_Click()
Dim c As Range
Dim p As String
Dim actives As String
actives = ActiveSheet.Name
StopCode = False
Application.EnableCancelKey = xlErrorHandler
On Error GoTo ErrH:
DoEvents
For Each c In Sheets(actives).UsedRange.Cells
If StopCode = True Then
Exit For
End If
DoEvents
If Left(c, 7) = "172.21." Then
p = sPing(c)
[...]
End If
Next c
End Sub
As already noted in the comments, to prevent this from blocking after each call, you need to invoke your pings asynchronously from your function. The way I would approach this would be to delegate your sPing(sHost) function to a VBScript that you create on the fly in a temp folder. The script would look something like this, and it takes the IP address as a command line argument and outputs the result to a file:
Dim args, ping, status
Set ping = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & Wscript.Arguments(0) & "'")
Dim result
For Each status In ping
If IsNull(status.StatusCode) Or status.StatusCode <> 0 Then
result = "timeout"
Else
result = result & vbTab & status.ResponseTime
End If
Next
Dim fso, file
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.CreateTextFile(Wscript.Arguments(0), True)
file.Write result
file.Close
You can create a Sub to write this to a path something like this:
Private Sub WriteScript(path As String)
Dim handle As Integer
handle = FreeFile
Open path & ScriptName For Output As #handle
Print #handle, _
"Dim args, ping, status" & vbCrLf & _
"Set ping = GetObject(""winmgmts:{impersonationLevel=impersonate}"").ExecQuery _" & vbCrLf & _
" (""select * from Win32_PingStatus where address = '"" & Wscript.Arguments(0) & ""'"")" & vbCrLf & _
"Dim result" & vbCrLf & _
"For Each status In ping" & vbCrLf & _
" If IsNull(status.StatusCode) Or status.StatusCode <> 0 Then" & vbCrLf & _
" result = ""timeout""" & vbCrLf & _
" Else" & vbCrLf & _
" result = result & vbTab & status.ResponseTime" & vbCrLf & _
" End If" & vbCrLf & _
"Next" & vbCrLf & _
"Dim fso, file" & vbCrLf & _
"Set fso = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _
"Set file = fso.CreateTextFile(Wscript.Arguments(0), True)" & vbCrLf & _
"file.Write result" & vbCrLf & _
"file.Close"
Close #handle
End Sub
After that, it's pretty straightforward - create a new directory in the user's temp directory, plop the script in there, and then use the Shell command to run each ping in its own process. Wait for the length of your timeout, then read the results from the files:
Private Const TempDir = "\PingResults\"
Private Const ScriptName As String = "ping.vbs"
'Important - set this to the time in seconds of your ping timeout.
Private Const Timeout = 4
Sub pingall_Click()
Dim sheet As Worksheet
Set sheet = ActiveSheet
Dim path As String
'Create a temp folder to use.
path = Environ("Temp") & TempDir
MkDir path
'Write your script to the temp folder.
WriteScript path
Dim results As Dictionary
Set results = New Dictionary
Dim index As Long
Dim ip As Variant
Dim command As String
For index = 1 To sheet.UsedRange.Rows.Count
ip = sheet.Cells(index, 1)
If Len(ip) >= 7 Then
If Left$(ip, 1) = "172.21." Then
'Cache the row it was in.
results.Add ip, index
'Shell the script.
command = "wscript " & path & "ping.vbs " & ip
Shell command, vbNormalFocus
End If
End If
Next index
Dim completed As Double
completed = Timer + Timeout
'Wait for the timeout.
Do While Timer < completed
DoEvents
Loop
Dim handle As String, ping As String, result As String
'Loop through the resulting files and update the sheet.
For Each ip In results.Keys
result = Dir$(path & ip)
If Len(result) <> 0 Then
handle = FreeFile
Open path & ip For Input As #handle
ping = Input$(LOF(handle), handle)
Close #handle
Kill path & ip
Else
ping = "timeout"
End If
sheet.Cells(results(ip), 2) = ping
Next ip
'Clean up.
Kill path & "*"
RmDir path
End Sub
Note that this has exactly zero error handling for the file operations, and doesn't respond to your StopCode flag. It should give the basic gist of it though. Also note that if you need to allow the user to cancel it, you won't be able to remove the temp directory because it will still be in use. If that is the case, only create it if it isn't already there and don't remove it when you're done.
You might be able to implement something like this, but I haven't tried it with multiple servers
if your network is fast you can reduce the timeout to 500 ms or less:
.
Public Function serverOk(ByVal dbSrvrNameStr As String) As Boolean
Const PINGS As Byte = 1
Const PING_TIME_OUT As Byte = 500
Const PING_LOCATION As String = "C:\Windows\System32\"
Dim commandResult As Long, serverIsActive As Boolean
commandResult = 1
serverIsActive = False
If Len(dbSrvrNameStr) > 0 Then
Err.Clear
With CreateObject("WScript.Shell")
commandResult = .Run("%comspec% /c " & PING_LOCATION & "ping.exe -n " & PINGS & " -w " & PING_TIME_OUT & " " & dbSrvrNameStr & " | find ""TTL="" > nul 2>&1", 0, True)
commandResult = .Run("%comspec% " & PING_LOCATION & "/c ping.exe -n " & PINGS & " -w " & PING_TIME_OUT & " " & dbSrvrNameStr, 0, True)
serverIsActive = (commandResult = 0)
End With
If serverIsActive And Err.Number = 0 Then
'"DB Server - valid, Ping response: " & commandResult
Else
'"Cannot connect to DB Server, Error: " & Err.Description & ", Ping response: " & commandResult
End If
Err.Clear
End If
serverOk = serverIsActive
End Function
.
Link to "Run Method (Windows Script Host)" from Microsoft:
https://msdn.microsoft.com/en-us/library/d5fk67ky(VS.85).aspx
The 3rd parameter of this command can be overlooked: "bWaitOnReturn" - allows you to execute it asynchronously from VBA
I am Using below code to open autocad file :
Dim DwgName As String
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
Set acadApp = CreateObject("AutoCAD .Application")
Err.Clear
End If
Set acadDoc = acadApp.ActiveDocument
If acadDoc.FullName <> DwgName Then
acadDoc.Open DwgName
End If
Dim str As String, str1 As String
str1 = "_-insert" & vbLf & """" & "C:\AZ665.dwg" & """" & vbLf & "0,0,0" & vbLf & vbLf & vbLf & vbLf & "z" & vbLf & "a" & vbLf
acadDoc.SendCommand str1
acadApp.Visible = True
Above code working fine.But everytime I have to create "str1" string in order to make any changes. Hence I am writting scipt in ".scr" file.But unable to call this file.
Please help.
The following code will read a .scr file and create the string you need for your SendCommand
Dim strData as string
x = FreeFile
Open "myscript.scr" For Input As #x
Do
Line Input #x, strData
str1 = str1 & strData & vbNewLine
If EOF(x) Then Exit Do
Loop
Close #x
I found below solution :
acadDoc.SendCommand "_script" & vbCr & ScriptFilePath & vbCr
i have this very simple chat app made in VB6 using winsock, but as you can see it only accept only one connexion, how can i handle multiple users? Thanks!
Private Sub Winsock1_Close()
' Finaliza la conexión
Winsock1.Close
txtLog = txtLog & "*** Desconectado" & vbCrLf
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
If Winsock1.State <> sckClosed Then
Winsock1.Close ' close
End If
Winsock1.Accept requestID
txtLog = "Cliente conectado. IP : " & _
Winsock1.RemoteHostIP & vbCrLf
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim dat As String
Winsock1.GetData dat, vbString
txtLog = txtLog & "Cliente : " & dat & vbCrLf
End Sub
The solution is to have an array of Winsock objects, and create a new one at runtime. The new object you have created accepts the connection request.
So, in your connection request sub, you would have a new socket:
Dim ConnectionCount as long
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
ConnectionCount=ConnectionCount+1
Load Winsocks(ConnectionCount)
Winsocks(ConnectionCount).Accept(requestID)
txtLog = "Cliente conectado. IP : " & _
Winsocks(ConnectionCount).RemoteHostIP & vbCrLf
End Sub
Edit: Here is a tutorial that may help you better than my code: http://www.devx.com/tips/Tip/5488
It follows the same idea.