ActiveX calling URL page - sql

I'm using the following code inside an ActiveX Script job on SQl Server to call an URL every X minutes.
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run "iexplore.exe http://www.google.com.br"
Set WsShell = Nothing
it is working but the processes created keep running:
Any way of changin that code to call the URL and kill the recent called process or call it with a "time-to-live". I think it is more secure, I wouldn't want to kill the wrong process.

Following up on the suggestion by #Ted, you can also fetch a URL using native Microsoft capabilities in an in-process fashion. You can do this via a component known as WinHTTP (the latest appears to be WinHTTP 5.1).
See my script below which includes a function to simply obtain the status of a URL. When I run this script I get the following output:
http://www.google.com => 200 [OK]
http://www.google.com/does_not_exist => 404 [Not Found]
http://does_not_exist.google.com => -2147012889
[The server name or address could not be resolved]
If you want the actual content behind a URL, try oHttp.ResponseText. Here's the WinHTTP reference if you are interested in other capabilities as well.
Option Explicit
Dim aUrlList
aUrlList = Array( _
"http://www.google.com", _
"http://www.google.com/does_not_exist", _
"http://does_not_exist.google.com" _
)
Dim i
For i = 0 To UBound(aUrlList)
WScript.Echo aUrlList(i) & " => " & GetUrlStatus(aUrlList(i))
Next
Function GetUrlStatus(sUrl)
Dim oHttp : Set oHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
On Error Resume Next
With oHttp
.Open "GET", SUrl, False
.Send
End With
If Err Then
GetUrlStatus = Err.Number & " [" & Err.Description & "]"
Else
GetUrlStatus = oHttp.Status & " [" & oHttp.StatusText & "]"
End If
Set oHttp = Nothing
End Function

The way you start IE is external, you have little control over the process once it is started.
A better interactive way is like this
Function GetData(strUrl) 'As String
Set web = CreateObject("InternetExplorer.Application")
web.Navigate strUrl
Do While web.Busy
wscript.sleep 100
Loop
Set doc = Nothing
Do Until Not doc Is Nothing
Set doc = web.Document
Loop
strWebPage = doc.all(1).innerHTML 'This does return the head sections
web.Quit
GetData = strWebPage
End Function
wscript.echo GetData("www.google.com")

UPDATE: As it stands now, it looks like this is not a viable solution. After multiple invocations, IE processes begin to accumulate with this approach as well. It appears this behavior has something to do with IE's session management. IE doesn't like to be abruptly terminated.
I found some very useful information about managing processes via WMI here. Using that as a basis, I came up with the code I show below. One of the nice aspects of the WMI approach is that you are given access to the unique ID for the process. I consider my code a starting point as I'm sure further improvements are possible (including the addition of exception handling).
Perhaps others with deeper knowledge of WMI can offer additional advice.
PS: Hope you like that I wrapped this functionality inside a VBScript class called Process.
Option Explicit
' Const PROG = "notepad.exe"
Const TARGET = "http://www.google.com"
Dim PROG : PROG = "C:\Program Files\Internet Explorer\iexplore.exe " & TARGET
Const ABOVE_NORMAL = 32768 ' what are the other priority constants?
Dim oProc : Set oProc = New Process
oProc.Name = PROG
' oProc.Priority = ABOVE_NORMAL
oProc.Launch
WScript.Echo "Launched '" & PROG & "' with process ID '" & oProc.ID & "'"
WScript.Sleep 5000
oProc.Terminate
WScript.Echo "Process " & oProc.ID & " killed."
Set oProc = Nothing
' ----------------------------------------------------------------------
Class Process
Public Computer
Public Name
Public Priority
Public ID
Public IsRunning
Private mHandle
Private Sub Class_Initialize()
Me.Computer = "."
Me.Name = Null
Me.ID = -1
Me.Priority = Null
Me.IsRunning = False
Set mHandle = Nothing
End Sub
Private Sub Class_Terminate()
Set mHandle = Nothing
End Sub
Public Sub Launch()
Dim oWmi, oStartup, oConfig
Dim nPid
Set oWmi = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& Me.Computer & "\root\cimv2")
Set oStartup = oWmi.Get("Win32_ProcessStartup")
If Not IsNull(Me.Priority) Then
Set oConfig = oStartup.SpawnInstance_
oConfig.PriorityClass = Me.Priority
End If
Set mHandle = GetObject("winmgmts:root\cimv2:Win32_Process")
mHandle.Create Me.Name, Null, oConfig, nPid
' WScript.Echo "TypeName Is [" & TypeName(mHandle) & "]"
Me.ID = nPid
Me.IsRunning = True
End Sub
Public Sub Terminate()
' mHandle.Terminate ' hmmm, doesn't work...
Dim oWmi
Dim colProcessList, oProc
Set oWmi = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& Me.Computer & "\root\cimv2")
Set colProcessList = oWmi.ExecQuery _
("Select * from Win32_Process Where ProcessId = '" & Me.ID & "'")
For Each oProc In colProcessList ' should be only one process
' WScript.Echo "TypeName Is [" & TypeName(oProc) & "]"
oProc.Terminate
Next
Me.IsRunning = False
End Sub
End Class

Could you consider using a lightweight command line URL retrieval program, like CURL ( http://curl.haxx.se/docs/manpage.html ) or WGET ( http://www.gnu.org/software/wget/ )? These programs can be executed from the command line quite simply:
wget http://www.google.com
curl http://www.google.com
You can execute them from VBScript like this:
sub shell(cmd)
' Run a command as if you were running from the command line
dim objShell
Set objShell = WScript.CreateObject( "WScript.Shell" )
objShell.Run(cmd)
Set objShell = Nothing
end sub
shell "wget http://www.google.com"
The only downside to this is that WGET and CURL won't execute javascript, download affiliated images, or render the HTML; they will simply download the web page. In my experience, I use CURL and WGET regularly as long as I only have to retrieve a single HTML page; but if I have to render something or trigger AJAX functions I use an automatable web browser toolkit like Selenium, WATIN, or IMacros.

Related

How Do I Automatically Update the ChromeDriver or EdgeDriver in VBA?

I have searched the web for a solution to "auto-update" my Selenium EdgeDriver automatically. For those who use SeleniumBasic, you know it can be a hassle to manually download the driver from the respective webpage every so often when your main Host browser gets a major update.
In my web searching, I have found support for other languages to "auto-update" their versions of these drivers, but VBA, as usual, was lacking support.
Now I don't claim this to be the perfect solution, but it at least works. The problem I can see in the future is that layouts of each respective webpage may change, so I do welcome updates if this is the case and I will try to update as well. But for the most part, it should just work.
While this is a Self-Answered question, I absolutely would love to see other methods posted here for myself and other users to try out. SeleniumBasic is a good tool for certain applications, but often lacks community support as VBA is not as widely used in the community as other languages - at least not on a more sophisticated level.
I should start out by saying that I am only supporting Chrome and Edge drivers for the time being. But if you can follow along, you might be able to add your own support for any of the other SeleniumBasic-supported WebDrivers.
Before we get started, it is important to enable the following References by going to Tools > References within the VBE:
Next, you need to create a Class Module named SeleniumWebDriver.
I decided to make this a Class Object because I intend to build a little on it in the future. You may add your own Properties and functions as you wish, but the code being provided will only allow updating the WebDrivers, at least for now.
Here is the complete Class Module Code:
Option Explicit
Rem Did Chrome change their file url and break your code?
' Check for an update: https://stackoverflow.com/a/67996166/5781745
Private ChromeDriver As Selenium.ChromeDriver
Private EdgeDriver As Selenium.EdgeDriver
Private SeleniumFolder As String
Private TempZipFile As String
Private ChromeInit As Boolean, EdgeInit As Boolean
Public Enum dType
Chrome
Edge
End Enum
Public Property Get SeleniumFolderPath() As String
SeleniumFolderPath = SeleniumFolder
End Property
Public Property Let SeleniumFolderPath(ByVal FolderPath As String)
SeleniumFolder = FolderPath
End Property
Public Sub UpdateDriver(ByVal DriverType As dType)
'URLs to the drivers' home pages to which we can grab the curr versions
Dim URLPath As String
Select Case DriverType
Case dType.Chrome
URLPath = "https://chromedriver.chromium.org/home"
Case dType.Edge
URLPath = "https://developer.microsoft.com/en-us/microsoft-edge/tools/webdriver/"
End Select
'Grab the current Version # from the driver's webpage
Dim Doc As New HTMLDocument, DriverVer As String
With New MSXML2.XMLHTTP60
.Open "GET", URLPath
.send
Doc.body.innerHTML = .responseText
End With
DriverVer = getCurrentVersion(Doc, DriverType)
DownloadUpdatedDriver DriverVer, DriverType
ExtractZipAndCopy DriverType
End Sub
' For use in a later project. Not needed at this time
Private Sub InitializeDriver(ByVal DriverType As dType)
Select Case DriverType
Case dType.Chrome
Set ChromeDriver = New Selenium.ChromeDriver
ChromeDriver.Start
ChromeInit = True
Case dType.Edge
Set EdgeDriver = New Selenium.EdgeDriver
EdgeDriver.Start
EdgeInit = True
End Select
End Sub
Private Function getCurrentVersion(Doc As HTMLDocument, DriverType As dType) As String
Dim div As HTMLDivElement
Select Case DriverType
Case dType.Chrome
For Each div In Doc.getElementsByTagName("p")
If div.innerText Like "Latest stable release*" Then
With New VBScript_RegExp_55.RegExp
.Pattern = "ChromeDriver\s([\d\.]+)\b"
getCurrentVersion = .Execute(div.innerText)(0).SubMatches(0)
Exit Function
End With
End If
Next
Case dType.Edge
With New VBScript_RegExp_55.RegExp
.Pattern = "Version:\s([\d\.]+)"
For Each div In Doc.getElementsByClassName("module")(0).getElementsByTagName("p")
If .test(div.innerText) Then
getCurrentVersion = .Execute(div.innerText)(0).SubMatches(0)
Exit Function
End If
Next
End With
End Select
End Function
Private Sub DownloadUpdatedDriver(ByVal CurrVersion As String, DriverType As dType)
Dim URLPath As String
Select Case DriverType
Case dType.Chrome
URLPath = "https://chromedriver.storage.googleapis.com/" & CurrVersion & "/chromedriver_win32.zip"
Case dType.Edge
Kill Environ$("LocalAppData") & "\SeleniumBasic\Driver_Notes\*.*"
URLPath = "https://msedgedriver.azureedge.net/" & CurrVersion & "/edgedriver_win64.zip"
End Select
Dim FileStream As New ADODB.Stream
With New MSXML2.XMLHTTP60
.Open "GET", URLPath
.send
FileStream.Open
FileStream.Type = adTypeBinary
FileStream.Write .responseBody
FileStream.SaveToFile TempZipFile, adSaveCreateOverWrite
FileStream.Close
End With
End Sub
Private Sub ExtractZipAndCopy(ByVal DriverType As dType)
Dim FileName As String
Select Case DriverType
Case dType.Chrome: FileName = "\chromedriver.exe"
Case dType.Edge: FileName = "\edgedriver.exe"
End Select
'Delete the old WebDriver
Kill SeleniumFolder & FileName
'Copy the new driver from .zip file to SeleniumBasic folder
Dim oShell As New shell
oShell.Namespace(SeleniumFolder).CopyHere oShell.Namespace(TempZipFile).Items
'Selenium VBA expects 'edgedriver' for edge, but new drivers are named 'msedgedriver'.
'If we are updating Edge, we need to rename the file
If DriverType = dType.Edge Then
Name SeleniumFolder & "msedgedriver.exe" As SeleniumFolder & "edgedriver.exe"
End If
'Delete the temporary zip file
Kill TempZipFile
End Sub
Private Sub Class_Initialize()
' Set the default file path. Can be modified later using ChromeDriverPath property
SeleniumFolder = Environ$("LocalAppData") & "\SeleniumBasic\"
TempZipFile = Environ$("LocalAppData") & "\Temp\WebDriver.zip"
End Sub
Now that you've created your Selenium Class, you can now use it in a standard module such as:
Important Tip: I am not sure if there is a delay between when you update your web browser and when the drivers are officially released. Therefore before updating your driver, I would put some error handling to see if Selenium throws an error first. If the driver does not match the browser version, Selenium will throw error # 33. If you check for this error, you should be safe to go ahead and update the WebDriver at this point. What we want to prevent is that you update your driver before your browser is automatically updated, causing mismatching versions.
It is also possible that your browser may update and the Selenium driver hasn't been released yet - but unfortunately that is not something that we can control.
The remainder of this answer will just go into some detail as to what it's doing. If you don't care, you may leave now.
First, as with any other object, we have to initialize it. In the above example, we do that with the With New SeleniumWebDriver statement. This fires the Class_Initialize() event here:
Private Sub Class_Initialize()
' Set the default file path. Can be modified later using ChromeDriverPath property
SeleniumFolder = Environ$("LocalAppData") & "\SeleniumBasic\"
TempZipFile = Environ$("LocalAppData") & "\Temp\WebDriver.zip"
End Sub
The purpose of this is to set the default file paths for the SeleniumBasic folder and temp file. However, if your folder is somewhere else, this class has a property to which you can change the folder manually. Just use the ClassObj.SeleniumFolderPath() property to establish your new path.
The TempZipFile is a class-scoped variable that will store the .zip file you download from the respective websites.
Upon calling the UpdateDriver method, the class will place a GET request to the respective driver's webpage, then grab the current version # from the page. It will then pass this driver version to the DownloadUpdatedDriver routine, which stores the download links for each respective driver. For Chrome, the link is: https://chromedriver.storage.googleapis.com/<Version#>/chromedriver_win32.zip, and for Edge it's: https://msedgedriver.azureedge.net/<Version#>/edgedriver_win64.zip. It's important to realize that if you happen to be using the 32 bit version of Edge, you will need to change the URL to edgedriver_win32.zip. This routine downloads the .zip file to your local AppData's Temp Folder.
After the file has been downloaded, we then proceed to call the ExtractZipAndCopy routine. This simply extracts the .exe files to the Selenium Folder, first deleting the old file. Edge does a little extra maintenance work, but you're now essentially updated!
I hope this helps someone out there who is annoyed as I am having to periodically update these drivers and was wanting an automated solution. Please feel free to edit this answer if minor changes are needing to be made, such as if a URL is broken.
There is now an API to check Latest Release of ChromeDriver. So the code can become shorter. Also, adding a functionality to run the update only if the current chrome version does not match installed chromedriver version. And to copy using administrator rights.
I am not using Edge so that code functionality is not there in my code.
Function chkchromever()
Tempfolder = "D:\"
TempZipFile = Tempfolder & "Chromedriver.zip"
SeleniumFolder = Environ$("ProgramW6432") & "\SeleniumBasic\"
TempDrvFile = Tempfolder & "Chromedriver.exe"
'Delete chromedriver.exe from temporary folder if it already exists
If Dir(TempDrvFile) <> "" Then
Kill (TempDrvFile)
End If
Dim oShell As New WshShell
Dim objHttp As Object
Set objHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
'Get chrome version
chrversion = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Software\Google\Chrome\BLBeacon\version")
dotsarr = Split(chrversion, ".")
leftchrver = dotsarr(0) & dotsarr(1)
'Get chromedriver version
gspath = Chr(34) & SeleniumFolder & "chromedriver.exe" & Chr(34)
torun = gspath & " --version"
errcode = oShell.Exec(torun).StdOut.ReadAll
verarr = Split(errcode, " ")
chrdrv = verarr(1)
dotsarr2 = Split(chrdrv, ".")
leftchrdrv = dotsarr(0) & dotsarr(1)
'If major version mismatch (first two numbers) then ask if update required
If leftchrver <> leftchrdrv Then
myyn = MsgBox("Wrong version of chromedriver. " & vbCrLf & "Chrome version is " & chrversion & vbCrLf & "Chrome driver version is " & chrdrv, vbYesNo, "Do you want to update Chromedriver ?")
If myyn = vbNo Then Exit Function
'Get latest release version of chromedriver which matches installed version of Chrome
url = "https://chromedriver.storage.googleapis.com/LATEST_RELEASE_" & dotsarr(0)
Call objHttp.Open("GET", url, False)
Call objHttp.send("")
version_number = objHttp.responseText
dotsarr3 = Split(version_number, ".")
leftversion_no = dotsarr3(0) & dotsarr3(1)
If leftchrver = leftversion_no Then
'If chromedriver found then download it
download_url = "https://chromedriver.storage.googleapis.com/" + version_number + "/chromedriver_win32.zip"
Call objHttp.Open("GET", download_url, False)
Call objHttp.send("")
Set fileStream = New ADODB.Stream
With fileStream
.Open
.Type = adTypeBinary
.Write objHttp.responseBody
.Position = 0
.SaveToFile TempZipFile, adSaveCreateOverWrite
.Close
End With
'Copy the new driver from .zip file to SeleniumBasic folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(Tempfolder).CopyHere oApp.Namespace(TempZipFile).Items
'Create batch file to copy chromedriver.exe to Seleniumbasic folder and run it using Administrator rights
tmpbatpath = Tempfolder & "copychdrv.bat"
'Check if Chromedriver downloaded successfully
If Dir(TempDrvFile) <> "" Then
Open tmpbatpath For Output As #1
'Enable these if required to copy chromedriver.exe
' Print #1, "taskkill /f /im GoogleCrashHandler.exe"
' Print #1, "taskkill /f /im GoogleCrashHandler64.exe"
' Print #1, "taskkill /f /im Chrome.exe"
' Print #1, "taskkill /f /im Googleupdate.exe"
If IsProcessRunning("Chromedriver.exe") Then
Print #1, "taskkill /f /im Chromedriver.exe"
End If
Print #1, "copy " & Chr(34) & TempDrvFile & Chr(34) & " " & Chr(34) & SeleniumFolder & "Chromedriver.exe" & Chr(34) & "/y"
Close #1
'copy it now by running batch file
success = ShellExecute(0, "runas", tmpbatpath, aPic, vbNullString, SW_SHOWNORMAL)
End If
'Cleanup
If Dir(TempZipFile) <> "" Then
Kill (TempZipFile)
End If
If Dir(tmpbatpath) <> "" Then
Kill (tmpbatpath)
End If
End If
End If
End Function
As i am on a company PC, I updated the code to work on a locked PC
Option Explicit
'**********************************************************
' PUBLIC FUNCTION
'/
'**********************************************************
' #Fn chkchromever
'
' #brief Check if Selenium Crome Driver is up to date or update it
'
' #param checks Crome version and Installed and availible Driver for Selenium
'
' #SUBs IsProcessRunning, ShellExecute
'
' Librarys Selenium Type library
' Windows Script Host Object Model - Dim oShell As New WshShell ,
' Microsoft ActiveX Data Objects 6.1 Library - Set fileStream = New ADODB.Stream
'
' #return new driver
'/
Public Declare Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal Hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
Function chkchromever()
Dim tempfolder As Variant, TempZipFile As Variant
Dim SeleniumFolder As String, TempDrvFile As String
Dim chrversion As String, leftchrver As String
Dim dotsarr() As String
Dim gspath As String, torun As String, errcode As String
Dim verarr() As String, chrdrv As String, leftchrdrv As String
Dim dotsarr2() As String
Dim myyn As Integer
Dim Url As String, version_number As String, leftversion_no As String
Dim dotsarr3() As String
Dim download_url As String
tempfolder = "C:\Temp\"
TempZipFile = tempfolder & "Chromedriver.zip"
'SeleniumFolder = Environ$("ProgramW6432") & "\SeleniumBasic\"
SeleniumFolder = Environ$("LOCALAPPDATA") & "\SeleniumBasic\"
TempDrvFile = tempfolder & "Chromedriver.exe"
'Delete chromedriver.exe from temporary folder if it already exists
If Dir(TempDrvFile) <> "" Then
Kill (TempDrvFile)
End If
Dim oShell As New WshShell
Dim objHttp As Object
Set objHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
'Get chrome version
chrversion = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Software\Google\Chrome\BLBeacon\version")
dotsarr = Split(chrversion, ".")
leftchrver = dotsarr(0) & dotsarr(1)
'Get chromedriver version
gspath = Chr(34) & SeleniumFolder & "chromedriver.exe" & Chr(34) ' chr34 er gåseøjne
torun = gspath & " --version"
errcode = oShell.Exec(torun).StdOut.ReadAll
verarr = Split(errcode, " ")
chrdrv = verarr(1)
dotsarr2 = Split(chrdrv, ".")
leftchrdrv = dotsarr2(0) & dotsarr2(1)
'If major version mismatch (first two numbers) then ask if update required
If leftchrver <> leftchrdrv Then
myyn = MsgBox("Wrong version of chromedriver. " & vbCrLf & "Chrome version is " & chrversion & vbCrLf & "Chrome driver version is " & chrdrv, vbYesNo, "Do you want to update Chromedriver ?")
If myyn = vbNo Then Exit Function
'Get latest release version of chromedriver which matches installed version of Chrome
Url = "https://chromedriver.storage.googleapis.com/LATEST_RELEASE_" & dotsarr(0)
Call objHttp.Open("GET", Url, False)
Call objHttp.send("")
version_number = objHttp.responseText
dotsarr3 = Split(version_number, ".")
leftversion_no = dotsarr3(0) & dotsarr3(1)
If leftchrver = leftversion_no Then
'If chromedriver found then download it
download_url = "https://chromedriver.storage.googleapis.com/" + version_number + "/chromedriver_win32.zip"
Call objHttp.Open("GET", download_url, False)
Call objHttp.send("")
Dim fileStream As Object
Set fileStream = New ADODB.Stream
With fileStream
.Open
.Type = adTypeBinary
.Write objHttp.responseBody
.Position = 0
.SaveToFile TempZipFile, adSaveCreateOverWrite
.Close
End With
'unzip file
Dim oApp As Object
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(tempfolder).CopyHere oApp.Namespace(TempZipFile).Items
'Check if Chromedriver downloaded successfully
If Dir(TempDrvFile) <> "" Then
If IsProcessRunning("Chromedriver.exe") Then
Shell "cmd /c""" & "taskkill /f /im Chromedriver.exe"
End If
'Copy / Overwrite file in SeleniumBasic folder
FileCopy TempDrvFile, SeleniumFolder & "Chromedriver.exe"
End If
'Cleanup
If Dir(TempZipFile) <> "" Then
Kill (TempZipFile)
End If
If Dir(TempDrvFile) <> "" Then
Kill (TempDrvFile)
End If
End If
End If
End Function
Function IsProcessRunning(process As String)
Dim objList As Object
Set objList = GetObject("winmgmts:") _
.ExecQuery("select * from win32_process where name='" & process & "'")
IsProcessRunning = objList.Count > 0
End Function
I had to modify the code posted above by Jesper Martin Schumacher as our IT department has updated all Office Applications to 64-bit.
That code was failing on instances of "New" keyword, so I researched and found:
compile error User-defined type not defined at "oShell As WshShell"
The suggestion there was to use "Late Binding" CreateObject method instead, as below.
Set oShell = CreateObject("WScript.Shell") 'Had to edit this line. It WAS "Set oShell = New WshShell"
Set fileStream = CreateObject("ADODB.Stream") 'Had to edit this line. It WAS "Set fileStream = New ADODB.Stream"

WScript.Shell Fails For Unknown Reasons VB6.5 [duplicate]

This question already has answers here:
VBS with Space in File Path
(4 answers)
Closed 4 years ago.
In VBA I am running a piece of external software I wrote. I know the software works well. I can run it from the command line. But when I attempt to execute it using WScript.Shell.Run, it returns a 1 and it never runs. I can't even tell that it executes the software at all.
Here is the executing portion of the VBA class.
Public Function Execute() As Integer
Dim wsh As Object
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim exitCode As Integer: exitCode = -1
Set wsh = VBA.CreateObject("WScript.Shell")
'Run program with arguments and wait for the program to finish
If Me.PrinterType = 1 Then exitCode = wsh.Run(Me.Path & " /serial=" & Me.SerialNumber & " /position=" & Me.Location & "", windowStyle, waitOnReturn)
If Me.PrinterType = 2 Then exitCode = wsh.Run(Me.Path & " /boxid=" & Me.Location & " /version=" & Me.Version, windowStyle, waitOnReturn)
Execute = exitCode
End Function
An example of the full execute string:
C:.path.to.\PrintLabel.exe /serial=EOSJ61110044 /position=2
Evidence that the script runs without error from the same machine the VBA is executing on:
So I've got no idea what's going on.
I can use the following VBA Shell function successfully:
If Me.PrinterType = 1 Then exitCode = Shell(Me.Path & " /serial=" & Me.SerialNumber & " /position=" & Me.Location, vbHide)
But the problem then becomes that the VBA doesn't wait on the software to finish before continuing. So I need to continue to try and make WScript.Shell work. What am I missing? Are there any specific references that need to be enabled that I could be missing?
Update 1:
Tried this to mimic this SO post, but still didn't have success:
If Me.PrinterType = 1 Then fullExecutionString = Me.Path & " /serial=" & Me.SerialNumber & " /position=" & Me.Location
If Me.PrinterType = 2 Then fullExecutionString = Me.Path & " /boxid=" & Me.Location & " /version=" & Me.Version
wsh.Run fullExecutionString, windowStyle, waitOnReturn
Update 2:
Made a small method that repeats the process in windows cmd console. It works (more or less) with the same code. I am guessing it has something to do with the command path string with arguments?
Private Sub Button2_Released()
Dim wsh As Object
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim exitCode As Integer: exitCode = 0
Set wsh = VBA.CreateObject("WScript.Shell")
exitCode = wsh.Run("C:\Windows\System32\cmd.exe", windowStyle, waitOnReturn)
End Sub
Answering my own question:
After much debugging I resolved that the path with spaces is causing the issue. If I directly input the following (notice the quote placement), the code successfully runs:
exitCode = wsh.Run("""C:\path.to\PrintLabel.exe"" /serial=EOSJ61110044 /position=2", windowStyle, waitOnReturn)
So in the end I adjusted my Path property:
Public Property Let Path(ByVal NewValue As String)
actPath = Chr(34) & NewValue & Chr(34)
End Property
Public Property Get Path() As String
Path = actPath
End Property

Quickest way to determine if a remote PC is online

I tend to run a lot of commands against remote PCs, but I always check to make sure they are online first. I currently use this code:
If objFSO.FolderExists("\\" & strHost & "\c$") Then
'The PC is online so do your thing
However, when the remote PC is not online, it takes my laptop ~45 seconds before it times out and resolves to FALSE.
Is there a way to hasten the timeout? Or is there another easily implementable solution to determine if a PC is online?
You could use WMI to ping it.
Function IsOnline(strHost As String) As Boolean
Dim strQuery As String
strQuery = "select * from Win32_PingStatus where Address = '" & strHost & "'"
Dim colItems As Object
Set colItems = GetObject("winmgmts://./root/cimv2").ExecQuery(strQuery)
Dim objItem As Object
For Each objItem In colItems
If IsObject(objItem) Then
If objItem.StatusCode = 0 Then
IsOnline = True
Exit Function
End If
End If
Next
End Function
You can use the return code from a ping request:
Function HostIsOnline(hostname)
Set oShell = WScript.CreateObject("WScript.Shell")
Set oShellExec = oShell.Exec("ping -n 1 " & hostname)
While oShellExec.Status = 0
WScript.Sleep(100)
Wend
HostIsOnline = (oShellExec.ExitCode = 0)
End Function

Object variable or With Block variable not set - Access 2010 VBA

Greetings to the well of knowledge...
I've been reading the numerous posts on this particular error and have not found anything that resolves my particular issue.
I have some VBA code within an Access 2010 front-end. Sometimes, but not always, I get a "Object variable or With block variable not set." error. My code is as follows:
Public Sub ValidateAddress(PassedAddress As Object, PassedCity As Object, PassedState As Object, _
PassedZIP As Object, PassedCongressionalDistrict As Object, PassedValidated As Object, HomeForm As Form)
On Error GoTo ShowMeError
Dim strUrl As String ' Our URL which will include the authentication info
Dim strReq As String ' The body of the POST request
Dim xmlHttp As New MSXML2.XMLHTTP60
Dim xmlDoc As MSXML2.DOMDocument60
Dim dbs As Database
Dim candidates As MSXML2.IXMLDOMNode, candidate As MSXML2.IXMLDOMNode
Dim components As MSXML2.IXMLDOMNode, metadata As MSXML2.IXMLDOMNode, analysis As MSXML2.IXMLDOMNode
Dim AddressToCheck As Variant, CityToCheck As Variant, StateToCheck As Variant, ZIPToCheck As Variant
Dim Validated As Boolean, District As Variant, MatchCode As Variant, Footnotes As Variant
Dim candidate_count As Long, SQLCommand As String, Start, Finish
' This URL will execute the search request and return the resulting matches to the search in XML.
strUrl = "https://api.smartystreets.com/street-address/?auth-id=<my_auth_id>" & _
"&auth-token=<my_auth_token>"
AddressToCheck = PassedAddress.Value
CityToCheck = PassedCity.Value
StateToCheck = PassedState.Value
If Len(PassedZIP) = 6 Then ZIPToCheck = Left(PassedZIP.Value, 5) Else ZIPToCheck = PassedZIP.Value
' Body of the POST request
strReq = "<?xml version=""1.0"" encoding=""utf-8""?>" & "<request>" & "<address>" & _
" <street>" & AddressToCheck & "</street>" & " <city>" & CityToCheck & "</city>" & _
" <state>" & StateToCheck & "</state>" & " <zipcode>" & ZIPToCheck & "</zipcode>" & _
" <candidates>5</candidates>" & "</address>" & "</request>"
With xmlHttp
.Open "POST", strUrl, False ' Prepare POST request
.setRequestHeader "Content-Type", "text/xml" ' Sending XML ...
.setRequestHeader "Accept", "text/xml" ' ... expect XML in return.
.send strReq ' Send request body
End With
' The request has been saved into xmlHttp.responseText and is
' now ready to be parsed. Remember that fields in our XML response may
' change or be added to later, so make sure your method of parsing accepts that.
' Google and Stack Overflow are replete with helpful examples.
Set xmlDoc = New MSXML2.DOMDocument60
If Not xmlDoc.loadXML(xmlHttp.ResponseText) Then
Err.Raise xmlDoc.parseError.errorCode, , xmlDoc.parseError.reason
Exit Sub
End If
' According to the schema (http://smartystreets.com/kb/liveaddress-api/parsing-the-response#xml),
' <candidates> is a top-level node with each <candidate> below it. Let's obtain each one.
Set candidates = xmlDoc.documentElement
' First, get a count of all the search results.
candidate_count = 0
For Each candidate In candidates.childNodes
candidate_count = candidate_count + 1
Next
Set candidates = xmlDoc.documentElement
Select Case candidate_count
Case 0 ' Bad address cannot be corrected. Try again.
Form_frmPeople.SetFocus
MsgBox "The address supplied does not match a valid address in the USPS database. Please correct this.", _
vbOKOnly, "Warning"
PassedAddress.BackColor = RGB(255, 0, 0)
PassedCity.BackColor = RGB(255, 0, 0)
PassedState.BackColor = RGB(255, 0, 0)
PassedZIP.BackColor = RGB(255, 0, 0)
Exit Sub
Case 1 ' Only one candidate address...use it and return.
For Each candidate In candidates.childNodes
Set analysis = candidate.selectSingleNode("analysis")
PassedAddress.Value = candidate.selectSingleNode("delivery_line_1").nodeTypedValue
Set components = candidate.selectSingleNode("components")
PassedCity.Value = components.selectSingleNode("city_name").nodeTypedValue
PassedState.Value = components.selectSingleNode("state_abbreviation").nodeTypedValue
PassedZIP.Value = components.selectSingleNode("zipcode").nodeTypedValue & "-" & _
components.selectSingleNode("plus4_code").nodeTypedValue
Set metadata = candidate.selectSingleNode("metadata")
PassedCongressionalDistrict.Value = CInt(metadata.selectSingleNode("congressional_district").nodeTypedValue)
PassedValidated.Value = True
Next
Exit Sub
Case Else ' Multiple candidate addresses...post them and allow the user to select.
DoCmd.SetWarnings False
Set dbs = CurrentDb
If IsTableQuery("temptbl") Then dbs.Execute "DROP TABLE temptbl"
dbs.Execute "CREATE TABLE temptbl (Selected BIT, CandidateAddress CHAR(50), CandidateCity CHAR(25), _
CandidateState CHAR(2), CandidateZIP CHAR(10), CandidateCongressionalDistrict INTEGER, _
MatchCode CHAR(1), Footnotes CHAR(30));"
DoCmd.SetWarnings True
Start = Timer
Do While Timer < Start + 1
DoEvents
Loop
For Each candidate In candidates.childNodes
Set components = candidate.selectSingleNode("components")
AddressToCheck = candidate.selectSingleNode("delivery_line_1").nodeTypedValue
CityToCheck = components.selectSingleNode("city_name").nodeTypedValue
StateToCheck = components.selectSingleNode("state_abbreviation").nodeTypedValue
ZIPToCheck = components.selectSingleNode("zipcode").nodeTypedValue & "-" & _
components.selectSingleNode("plus4_code").nodeTypedValue
Set metadata = candidate.selectSingleNode("metadata")
District = metadata.selectSingleNode("congressional_district").nodeTypedValue
Set analysis = candidate.selectSingleNode("analysis")
MatchCode = analysis.selectSingleNode("dpv_match_code").nodeTypedValue
Footnotes = analysis.selectSingleNode("dpv_footnotes").nodeTypedValue
DoCmd.SetWarnings False
dbs.Execute "INSERT INTO temptbl ( CandidateAddress, CandidateCity, CandidateState, CandidateZIP, _
CandidateCongressionalDistrict, MatchCode, Footnotes ) " & vbCrLf & "SELECT """ & AddressToCheck & _
""" AS Expr1, """ & CityToCheck & """ AS Expr2, """ & StateToCheck & """ AS Expr3, """ & _
ZIPToCheck & """ AS Expr4, " & District & " AS Expr5, """ & MatchCode & """ AS Expr6, """ & _
Footnotes & """ AS Expr7;"
DoCmd.SetWarnings True
Next
DoCmd.OpenForm "frmPeopleAddressMaintenance"
Do Until CurrentProject.AllForms("frmPeopleAddressMaintenance").IsLoaded = False
DoEvents
Loop
HomeForm.SetFocus
If IsTableQuery("temptbl") Then dbs.Execute "DROP TABLE temptbl"
End Select
dbs.Close
Exit Sub
ShowMeError:
MsgBox Err.Description, vbOKOnly, "ERROR!"
End Sub
The error occurs in two specific places:
Under the "Case 1": The error happens immediately after...
PassedCongressionalDistrict.Value = CInt(metadata.selectSingleNode("congressional_district").nodeTypedValue)
...is executed. I have debugged this and verified that the statement executed properly and that the value of the "PassedCongressionalDistrict" object is correct.
Then, under "Case Else": The For loop processes the first item list correctly, but fails with the identified error when beginning processing the second item, even though there is good and legitimate data in the second item.
I hope I've explained this well enough. I just can't seem to figure out (1) how to more fully debug this and (2) why the error occurs as it seems that I have all of my object variables defined properly.
Regards,
Ken
It's almost definitely because (on occasion) there is no child node member named "metadata" in the XML body - so when you try to bind your "metadata" object to the .selectSingleNode() method it returns Nothing. You can always check to make sure that it's actually bound...
'// ...start code snippet...
Set metadata = candidate.selectSingleNode("metadata")
If Not metadata is Nothing Then
PassedCongressionalDistrict.Value = CInt(metadata.selectSingleNode("congressional_district").nodeTypedValue)
End If
PassedValidated.Value = True
'// ...end code snippet...

Getting the currently logged-in windows user

I found this via google: http://www.mvps.org/access/api/api0008.htm
'******************** Code Start **************************
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Function fOSUserName() As String
' Returns the network login name
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)
If ( lngX > 0 ) Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = vbNullString
End If
End Function
'******************** Code End **************************
Is this the best way to do it?
You could also do this:
Set WshNetwork = CreateObject("WScript.Network")
Print WshNetwork.UserName
It also has a UserDomain property and a bunch of other things:
http://msdn.microsoft.com/en-us/library/907chf30(VS.85).aspx
You could also use Environ$ but the method specified by the question is better. Users/Applications can change the environment variables.
I generally use an environ from within VBA as in the following. I haven't had the problems that Ken mentions as possibilities.
Function UserNameWindows() As String
UserNameWindows = VBA.Environ("USERNAME") & "#" & VBA.Environ("USERDOMAIN")
End Function
Lots of alternative methods in other posts, but to answer the question: yes that is the best way to do it. Faster than creating a COM object or WMI if all you want is the username, and available in all versions of Windows from Win95 up.
Alternative way to do that - probably the API you mention is a better way to get username.
For Each strComputer In arrComputers
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem",,48)
For Each objItem in colItems
Wscript.Echo "UserName: " & objItem.UserName & " is logged in at computer " & strComputer
Next
there are lots of way to get the current logged user name in WMI.
my way is to get it through the username from process of 'explorer.exe'
because when user login into window, the access of this file according to the current user.
WMI script would be look like this:
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strIP & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process")
For Each objprocess In colProcessList
colProperties = objprocess.GetOwner(strNameOfUser, strUserDomain)
If objprocess.Name = "explorer.exe" Then
UsrName = strNameOfUser
DmnName = strUserDomain
End If
Next
for more detailcheck the link on :
http://msdn.microsoft.com/en-us/library/aa394599%28v=vs.85%29.aspx