How to pass multiple variables to a link/href without having to open the browser using VBScript? The goal is to save/insert/update depending on the parameters that was passed on the URL, and the IIS Webserver would have to do the database change instead of the VBScript. The VBScript runs on schedule and would not want to open browser on the server each time it is executed.
My VBS code below:
Function HTMLEncode(Text)
Dim i
Dim acode
Dim repl
HTMLEncode = Text
For i = Len(HTMLEncode) To 1 Step -1
acode = Asc(Mid(HTMLEncode, i, 1))
Select Case acode
Case 32
repl = " "
Case 34
repl = """
Case 38
repl = "&"
Case 60
repl = "<"
Case 62
repl = ">"
Case acode => 32 AND acode <= 127
' don't touch alphanumeric chars
Case Else
repl = "&#" & CStr(acode) & ";"
End Select
If Len(repl) Then
HTMLEncode = Left(HTMLEncode, i - 1) & repl & Mid(HTMLEncode,+ 1)
repl = ""
End If
Next
End Function
strBody = "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.0 Transitional//EN"">" & _
"<html>" & _
"<head>" & _
"<title>TEST</title>" & _
"</head>" & _
"<body bgcolor=""#FFFFFF"">" & _
"<p> The user bla bla bla </p>" & _
"<p><b> " & _
"<br><br><br><br> This message is sent from an un-monitored mailbox, please do not reply. " & _
"</p>" & _
"</body>" & _
"</html>"
strBody = HTMLEncode(strBody)
myURL = "http://www.test.com/sendmail.asp?body=" & strBody
Set req = CreateObject("MSXML2.XMLHTTP.6.0")
req.Open "GET", myURL, False
req.Send
Related
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 need to have a timer appear in a message box, coded in vbs. The message box needs to be in the bottom left corner of the screen, just above the start menu. It needs to not be able to exit, meaning it cannot be listed on the task bar (hopefully) and have no minimise/exit buttons. It needs to stay on top of all the other windows. It also needs to start at 20 minutes, counting down in seconds. I hope someone can help me with this - it's for a computer lab.
Thanks,
Matthew
Try something like that :
Option Explicit
Dim Title,ws,nMinutes,nSeconds,sMessage
Title = "Counting Down to Shutdown"
Set ws = CreateObject("wscript.Shell")
nMinutes = 20
nSeconds = 0
sMessage = "<font color=Red size=2><b>Counting Down to Shutdown"
'Open a chromeless window with message
with HTABox("lightBlue",100,250,0,630)
.document.title = "Counting Down Notification to Shutdown"
.msg.innerHTML = sMessage
do until .done.value or (nMinutes + nSeconds < 1)
.msg.innerHTML = sMessage & "<br>" & nMinutes & ":" & Right("0"&nSeconds, 2) _
& " remaining</b></font><br>"
wsh.sleep 1000 ' milliseconds
nSeconds = nSeconds - 1
if nSeconds < 0 then
if nMinutes > 0 then
nMinutes = nMinutes - 1
nSeconds = 59
end if
end if
loop
.done.value = true
.close
end with
ws.Popup "TIME IS OVER !","5",Title,0+48 'Afficher un Popup durant 5 secondes puis on quitte le script
'Command="cmd /c Shutdown.exe -s -t 30 -c " & DblQuote("Sauvegarder votre Travail car l'ordinateur va rebooter dans 30 secondes")
'Executer = WS.Run(Command,0,False)
'*****************************************************************
Function HTABox(sBgColor, h, w, l, t)
Dim IE, HTA, sCmd, nRnd
randomize : nRnd = Int(1000000 * rnd)
sCmd = "mshta.exe ""javascript:{new " _
& "ActiveXObject(""InternetExplorer.Application"")" _
& ".PutProperty('" & nRnd & "',window);" _
& "window.resizeTo(" & w & "," & h & ");" _
& "window.moveTo(" & l & "," & t & ")}"""
with CreateObject("WScript.Shell")
.Run sCmd, 1, False
do until .AppActivate("javascript:{new ") : WSH.sleep 10 : loop
end with 'WSHShell
For Each IE In CreateObject("Shell.Application").windows
If IsObject(IE.GetProperty(nRnd)) Then
set HTABox = IE.GetProperty(nRnd)
IE.Quit
HTABox.document.title = "HTABox"
HTABox.document.write _
"<HTA:Application contextMenu=no border=thin " _
& "minimizebutton=no maximizebutton=no sysmenu=no SHOWINTASKBAR=no >" _
& "<body scroll=no style='background-color:" _
& sBgColor & ";font:normal 10pt Arial;" _
& "border-Style:inset;border-Width:3px'" _
& "onbeforeunload='vbscript:if not done.value then " _
& "window.event.cancelBubble=true:" _
& "window.event.returnValue=false:" _
& "done.value=true:end if'>" _
& "<input type=hidden id=done value=false>" _
& "<center><span id=msg> </span><br>" _
& "<input type=button id=btn1 value=' OK ' "_
& "onclick=done.value=true><center></body>"
HTABox.btn1.focus
Exit Function
End If
Next
MsgBox "HTA window not found."
wsh.quit
End Function
'*****************************************************************
I have a piece of script, courtosey of the user Hackoo, but two things are wrong with it. First, the window needs to stay on top, it shouldn't be able to be exited from the taskbar, it needs to be on the bottom right corner of the screen (above the taskbar) and it needs to have a button on it below the text that says "Log off". Of course, the log off button needs to log off the computer. Here's the code:
Option Explicit
Dim Title,ws,nMinutes,nSeconds,sMessage
Title = "Session Timer"
Set ws = CreateObject("wscript.Shell")
nMinutes = 20
nSeconds = 0
sMessage = "<font color=Red size=2><b>You have"
'Open a chromeless window with message
with HTABox("lightBlue",100,250,0,630)
.document.title = "Session Timer"
.msg.innerHTML = sMessage
do until .done.value or (nMinutes + nSeconds < 1)
.msg.innerHTML = sMessage & "<br>" & nMinutes & ":" & Right("0"&nSeconds, 2) _
& " minutes of session time remaining</b></font><br>"
wsh.sleep 1000 ' milliseconds
nSeconds = nSeconds - 1
if nSeconds < 0 then
if nMinutes > 0 then
nMinutes = nMinutes - 1
nSeconds = 59
end if
end if
loop
.done.value = true
.close
end with
ws.Popup "Your session time has finished. You will now be logged off.","5",Title,0+48
'*****************************************************************
Function HTABox(sBgColor, h, w, l, t)
Dim IE, HTA, sCmd, nRnd
randomize : nRnd = Int(1000000 * rnd)
sCmd = "mshta.exe ""javascript:{new " _
& "ActiveXObject(""InternetExplorer.Application"")" _
& ".PutProperty('" & nRnd & "',window);" _
& "window.resizeTo(" & w & "," & h & ");" _
& "window.moveTo(" & l & "," & t & ")}"""
with CreateObject("WScript.Shell")
.Run sCmd, 1, False
do until .AppActivate("javascript:{new ") : WSH.sleep 10 : loop
end with 'WSHShell
For Each IE In CreateObject("Shell.Application").windows
If IsObject(IE.GetProperty(nRnd)) Then
set HTABox = IE.GetProperty(nRnd)
IE.Quit
HTABox.document.title = "HTABox"
HTABox.document.write _
"<HTA:Application contextMenu=no border=thin " _
& "minimizebutton=no maximizebutton=no sysmenu=no SHOWINTASKBAR=no >" _
& "<body scroll=no style='background-color:" _
& sBgColor & ";font:normal 10pt Arial;" _
& "border-Style:inset;border-Width:3px'" _
& "onbeforeunload='vbscript:if not done.value then " _
& "window.event.cancelBubble=true:" _
& "window.event.returnValue=false:" _
& "done.value=true:end if'>" _
& "<input type=hidden id=done value=false>" _
& "<center><span id=msg> </span><br>" _
& "<input type=button id=btn1 value=' OK ' "_
& "onclick=done.value=true><center></body>"
HTABox.btn1.focus
Exit Function
End If
Next
MsgBox "HTA window not found."
wsh.quit
End Function
Thanks,
Matthew
Note that i don't think that we can stay always on the top, but anyway just give a try for this modification, now you want it at the right corner not on the left and i added the button to Logoff the session:
Option Explicit
Dim Title,ws,nMinutes,nSeconds,sMessage,Command,Executer
Title = "Session Timer"
Set ws = CreateObject("wscript.Shell")
nMinutes = 20
nSeconds = 0
sMessage = "<font color=Red size=2><b>You have"
'Open a chromeless window with message
with HTABox("lightBlue",130,300,1070,600)
.document.title = "Session Timer"
.msg.innerHTML = sMessage
do until .done.value or (nMinutes + nSeconds < 1)
.msg.innerHTML = sMessage & "<br>" & nMinutes & ":" & Right("0"&nSeconds, 2) _
& " minutes of session time remaining</b></font><br>"
wsh.sleep 1000 ' milliseconds
nSeconds = nSeconds - 1
if nSeconds < 0 then
if nMinutes > 0 then
nMinutes = nMinutes - 1
nSeconds = 59
end if
end if
loop
.done.value = true
.close
end with
ws.Popup "Your session time has finished. You will now be logged off.","5",Title,0+48
Command ="cmd /c Shutdown.exe -l -f"
Executer = WS.Run(Command,0,False)
'*****************************************************************
Function HTABox(sBgColor,h, w, l, t)
Dim IE, HTA, sCmd, nRnd
randomize : nRnd = Int(1000000 * rnd)
sCmd = "mshta.exe ""javascript:{new " _
& "ActiveXObject(""InternetExplorer.Application"")" _
& ".PutProperty('" & nRnd & "',window);" _
& "window.resizeTo(" & w & "," & h & ");" _
& "window.moveTo(" & l & "," & t & ")}"""
with CreateObject("WScript.Shell")
.Run sCmd, 1, False
do until .AppActivate("javascript:{new ") : WSH.sleep 10 : loop
end with 'WSHShell
For Each IE In CreateObject("Shell.Application").windows
If IsObject(IE.GetProperty(nRnd)) Then
set HTABox = IE.GetProperty(nRnd)
IE.Quit
HTABox.document.title = "HTABox"
HTABox.document.write _
"<HTA:Application contextMenu=no border=thin " _
& "minimizebutton=no maximizebutton=no sysmenu=no SHOWINTASKBAR=no >" _
& "<body scroll=no style='background-color:" _
& sBgColor & ";font:normal 10pt Arial;" _
& "border-Style:inset;border-Width:3px'" _
& "onbeforeunload='vbscript:if not done.value then " _
& "window.event.cancelBubble=true:" _
& "window.event.returnValue=false:" _
& "done.value=true:end if'>" _
& "<input type=hidden id=done value=false>" _
& "<center><span id=msg> </span><br>" _
& "<input type=button id=btn1 value=' Log Off ' "_
& "onclick=done.value=true><center></body>"
HTABox.btn1.focus
Exit Function
End If
Next
MsgBox "HTA window not found."
wsh.quit
End Function
I found a VB Script example for opening a file browser, which I used in a custom action in WiX. However, the VB Script function I use is called BrowseForFolder() (not browseforfile) and only seems to return a value when a directory is selected, but not when an individual file is selected. Here is the custom action:
<CustomAction Id="File" Script="vbscript" Execute="immediate" Return="ignore">
<![CDATA[
Dim shell
Set shell = CreateObject("Shell.Application")
Dim file
Set file = shell.BrowseForFolder(0, "Choose a file:", &H4000)
Session.Property("FileName") = file.self.Path
]]>
</CustomAction>
Using this method, I can actually see individual files in the dialog, which is a step up from Wix's built-in directory browser.
Now I just need to be able to retrieve individual file names, not just names of folders.
I've found this code.
https://gist.github.com/wangye/1932941
and made some changes on it to a better understanding
WScript.Echo GetOpenFileName("C:\", "")
'
' Description: VBScript/VBS open file dialog
' Compatible with most Windows platforms
' Author: wangye <pcn88 at hotmail dot com>
' Website: http://wangye.org
'
' dir is the initial directory; if no directory is
' specified "Desktop" is used.
' filter is the file type filter; format "File type description|*.ext"
'
'
Public Function GetOpenFileName(dir, filter)
Const msoFileDialogFilePicker = 3
If VarType(dir) <> vbString Or dir="" Then
dir = CreateObject( "WScript.Shell" ).SpecialFolders( "Desktop" )
End If
If VarType(filter) <> vbString Or filter="" Then
filter = "All files|*.*"
End If
' try to choose the way to open the dialog box. Array: TryObjectNames
Dim i,j, objDialog, TryObjectNames
TryObjectNames = Array( _
"UserAccounts.CommonDialog", _
"MSComDlg.CommonDialog", _
"MSComDlg.CommonDialog.1", _
"Word.Application", _
"SAFRCFileDlg.FileOpen", _
"InternetExplorer.Application" _
)
On Error Resume Next
Err.Clear
For i=0 To UBound(TryObjectNames)
Set objDialog = WSH.CreateObject(TryObjectNames(i))
If Err.Number <> 0 Then
Err.Clear
Else
Exit For
End If
Next
' Select the way to dealing the object dialog
Select Case i
Case 0,1,2
' 0. UserAccounts.CommonDialog XP Only.
' 1.2. MSComDlg.CommonDialog MSCOMDLG32.OCX must registered.
If i=0 Then
objDialog.InitialDir = dir
Else
objDialog.InitDir = dir
End If
objDialog.Filter = filter
If objDialog.ShowOpen Then
GetOpenFileName = objDialog.FileName
End If
Case 3
' 3. Word.Application Microsoft Office must installed.
objDialog.Visible = False
Dim objOpenDialog, filtersInArray
filtersInArray = Split(filter, "|")
Set objOpenDialog = _
objDialog.Application.FileDialog( _
msoFileDialogFilePicker)
With objOpenDialog
.Title = "Open File(s):"
.AllowMultiSelect = False
.InitialFileName = dir
.Filters.Clear
For j=0 To UBound(filtersInArray) Step 2
.Filters.Add filtersInArray(j), _
filtersInArray(j+1), 1
Next
If .Show And .SelectedItems.Count>0 Then
GetOpenFileName = .SelectedItems(1)
End If
End With
objDialog.Visible = True
objDialog.Quit
Set objOpenDialog = Nothing
Case 4
' 4. SAFRCFileDlg.FileOpen xp 2003 only
' See http://www.robvanderwoude.com/vbstech_ui_fileopen.php
If objDialog.OpenFileOpenDlg Then
GetOpenFileName = objDialog.FileName
End If
Case 5
Dim IEVersion,IEMajorVersion, hasCompleted
hasCompleted = False
Dim shell
Set shell = CreateObject("WScript.Shell")
' ????IE??
IEVersion = shell.RegRead( _
"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\Version")
If InStr(IEVersion,".") > 0 Then
' ??????
IEMajorVersion = CInt(Left(IEVersion, InStr(IEVersion,".")-1))
If IEMajorVersion > 7 Then
' ???????7,?????IE7,???MSHTA??
' Bypasses c:\fakepath\file.txt problem
' http://pastebin.com/txVgnLBV
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim tempFolder : Set tempFolder = fso.GetSpecialFolder(2)
Dim tempName : tempName = fso.GetTempName()
Dim tempFile : Set tempFile = tempFolder.CreateTextFile(tempName & ".hta")
Dim tempBaseName
tempBaseName = tempFolder & "\" & tempName
tempFile.Write _
"<html>" & _
" <head>" & _
" <title>Browse</title>" & _
" </head>" & _
" <body>" & _
" <input type='file' id='f'>" & _
" <script type='text/javascript'>" & _
" var f = document.getElementById('f');" & _
" f.click();" & _
" var fso = new ActiveXObject('Scripting.FileSystemObject');" & _
" var file = fso.OpenTextFile('" & _
Replace(tempBaseName,"\", "\\") & ".txt" & "', 2, true);" & _
" file.Write(f.value);" & _
" file.Close();" & _
" window.close();" & _
" </script>" & _
" </body>" & _
"</html>"
tempFile.Close
Set tempFile = Nothing
Set tempFolder = Nothing
shell.Run tempBaseName & ".hta", 1, True
Set tempFile = fso.OpenTextFile(tempBaseName & ".txt", 1)
GetOpenFileName = tempFile.ReadLine
tempFile.Close
fso.DeleteFile tempBaseName & ".hta"
fso.DeleteFile tempBaseName & ".txt"
Set tempFile = Nothing
Set fso = Nothing
hasCompleted = True ' ??????
End If
End If
If Not hasCompleted Then
' 5. InternetExplorer.Application IE must installed
objDialog.Navigate "about:blank"
Dim objBody, objFileDialog
Set objBody = _
objDialog.document.getElementsByTagName("body")(0)
objBody.innerHTML = "<input type='file' id='fileDialog'>"
while objDialog.Busy Or objDialog.ReadyState <> 4
WScript.sleep 10
Wend
Set objFileDialog = objDialog.document.all.fileDialog
objFileDialog.click
GetOpenFileName = objFileDialog.value
End If
objDialog.Quit
Set objFileDialog = Nothing
Set objBody = Nothing
Set shell = Nothing
Case Else
MsgBox("No file dialog component found", MsgBoxStyle.Exclamation, "Error")
End Select
Set objDialog = Nothing
End Function
I am using the last example on this page in WMI to print out some Windows System Log information:
http://msdn.microsoft.com/en-us/library/aa394593(VS.85).aspx
I would also like to print out the binary data as well, but I am not sure how to do that in WScript. Here is my modified code:
' test.vbs
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colLoggedEvents = objWMIService.ExecQuery _
("Select * from Win32_NTLogEvent " _
& "Where Logfile = 'System' and SourceName = 'MySource'")
For Each objEvent in colLoggedEvents
Wscript.Echo "Category: " & objEvent.Category & VBNewLine _
& "Event Code: " & objEvent.EventCode & VBNewLine _
& "Message: " & objEvent.Message & VBNewLine _
& "Time Written: " & objEvent.TimeWritten & VBNewLine _
& "Event Type: " & objEvent.Type & VBNewLine _
& "Binary Data: " & objEvent.Data
Next
I get this error message from Windows Script Host when running test.vbs:
Error: Type mismatch, Code: 800A000D, Source: Microsoft VBScript runtime error
Any idea how to print the data out as a hex character string?
.Data is an array of integer values (little endian encoded wide characters from the looks of it). You'd need to ChrW() each pair of numbers and concatenate them to a string before you could print the data. A function like this might work:
Function ToStr(arr)
ToStr = ""
For i = 0 To UBound(arr) Step 2
ToStr = ToStr & ChrW(arr(i) + arr(i+1)*256)
Next
End Function