Outlook - Pass variable to be displayed in temporary Popup - vba

In Outlook I have setup the following code to temporarily display a message.
However I cannot work out how to pass a variable (aMessageLabel) containing the text to be displayed.
Sub Test()
Dim aShell
Set aShell = CreateObject("WScript.Shell")
aMessageLabel = Chr(34) & "No Emails to be Forwarded!" & Chr(34)
aShell.Run "mshta.exe vbscript:close(CreateObject(""WScript.shell"").Popup(aMessageLabel,5,""Message""))"
End Sub

this works
Sub Test()
' this is the resulting windows command (you can run at command prompt)
' mshta.exe vbscript:close(CreateObject("WScript.shell").Popup("No Emails to be Forwarded!",5,"Message"))
' the "5" is number of seconds that the popup message will live
Dim aShell
Set aShell = CreateObject("WScript.Shell")
aMessageLabel = "No Emails to be Forwarded!"
Dim cmd As String
' multiline
cmd = "mshta.exe vbscript:close(CreateObject(""WScript.shell"").Popup("""
cmd = cmd & aMessageLabel
cmd = cmd & """,5,""Message""))"
Debug.Print cmd
aShell.Run cmd
' one line
aShell.Run "mshta.exe vbscript:close(CreateObject(""WScript.shell"").Popup(""" & aMessageLabel & """,5,""Message""))"
End Sub

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"

Killing Two different Processes With VB

I am trying to figure out how to kill two processes at the same time I have managed to get one to work when it is opened but the other wont close.
Sub block()
For Each item As Process In Process.GetProcesses
If item.ProcessName = "taskmgr" And item.ProcessName = "cmd" Then
item.Kill()
End If
Next
End Sub
As noted by #Noodles and #Zaggler your logic is wrong on this line;
If item.ProcessName = "taskmgr" And item.ProcessName = "cmd" Then
This line essentially asks if the process name is "taskmgr" and if the same process name is "cmd". Since these two strings aren't the same "taskmgr" /= "cmd" this if clause will never be true. I suggest you do something like this;
Sub block()
For Each item As Process In Process.GetProcesses
If item.ProcessName = "taskmgr" Then
item.Kill()
ElseIf item.ProcessName = "cmd" Then
item.Kill()
End If
Next
End Sub
Or optionally if you plan to close many processes;
'declare at form loading or elsewhere
Dim proclist as new list (of string)
proclist.add("taskmgr")
proclist.add("cmd")
proclist.add("...")
Sub block()
For Each item As Process In Process.GetProcesses
If proclist.contains(item.ProcessName) Then
item.Kill()
End If
Next
End Sub
Give a try with this solution in vbscript :
Option Explicit
Dim Ws,fso,MainArray,LogFile,i,OutPut,count
Set Ws = CreateObject("Wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
MainArray = Array("taskmgr.exe","cmd.exe")
LogFile = Left(Wscript.ScriptFullName,InstrRev(Wscript.ScriptFullName, ".")) & "log"
count = 0
If fso.FileExists(LogFile) Then fso.DeleteFile LogFile
Set OutPut = fso.OpenTextFile(LogFile,2,True)
For i = LBound(MainArray) To UBound(MainArray)
Call Kill(MainArray(i))
Next
OutPut.WriteLine String(50,"*")
OutPut.WriteLine count & " Process were killed !"
OutPut.WriteLine String(50,"*")
If fso.FileExists(LogFile) Then
ws.run DblQuote(LogFile) 'To show the LogFile
End if
'******************************************
Sub Kill(MyProcess)
Dim colItems,objItem
Set colItems = GetObject("winmgmts:").ExecQuery("Select * from Win32_Process " _
& "Where Name like '%"& MyProcess &"%' AND NOT commandline like '%" & wsh.scriptname & "%'",,48)
For Each objItem in colItems
count= count + 1
OutPut.WriteLine Mid(objItem.CommandLine,InStr(objItem.CommandLine,""" """) + 2)
objItem.Terminate(0)
Next
End Sub
'***********************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'***********************************************

Displaying the output of Process.Start

I have a Process.Start command that I would like to see the output of, but the new window is opening and closing too quickly for me to see anything. Here is the code I have so far that I'm working with:
System.Diagnostics.Process.Start(Environment.GetEnvironmentVariable("VS110COMNTOOLS") & "..\Ide\MSTEST.EXE", "/Testsettings: """ & rwSettings & "" & " /Testcontainer: """ & rwContainer & "" & " /Resultsfile: """ & rwResults & "")
Unfortunately as I try to debug this if I allow this to run it flashes up the window but doesn't let me see what the error is, or if it's running successfully at all. I'm using VS2012 so I might just not be looking at the right view when I'm debugging.
Here is some code taen out of the middle of some logic, so it is not standalone. You can use ProcessStartInfo() and Process() to have more control:
Dim start_info As New ProcessStartInfo("sqlcmd", cmd)
start_info.UseShellExecute = False
start_info.CreateNoWindow = True
start_info.RedirectStandardOutput = True
start_info.RedirectStandardError = True
' Make the process and set its start information.
Dim proc As New Process()
proc.StartInfo = start_info
Dim dt As Date = Now()
' Start the process.
proc.Start()
' Attach to stdout and stderr.
Dim std_out As StreamReader = proc.StandardOutput() ' will not continue until process stops
Dim std_err As StreamReader = proc.StandardError()
' Retrive the results.
Dim sOut As String = std_out.ReadToEnd()
Dim sErr As String = std_err.ReadToEnd()

Poll a directory looking for files with a certain extension

I'm writing a script to look in a directory, read the file name and use a part of the file name to run a SQL query to amend a DB, then copy the files to a new location and delete the original.
Once this is done it sends an email confirmation to a predefined email address.
I have the majority in place but am not able to Poll a Dir and process all files that may be there. Im new to this VB.net stuff and to get the other stuff working iv just named it at the beginning.
Any help would be greatly appreciated.
Dim fileName As String = "C:\temp\Input\VBTEST1.success"
Dim pathname As String = "C:\temp\Input\"
Dim result As String
Dim sourceDir As String = "C:\temp\Input\"
Dim processedDir As String = "C:\temp\Input\Processed\"
Dim fList As String() = Directory.GetFiles(sourceDir, "*.success")
Dim sqlCommand As SqlCommand
Public Sub Main()
result = Path.GetFileName(fileName)
Console.WriteLine("GetFileName('{0}') returns '{1}'", fileName, result)
Dim betacell As String = result
betacell = (result.Remove(7, 8))
Dim connection As New SqlConnection(My.Settings.connectionString)
connection.Open()
Dim updateTransaction As SqlTransaction = connection.BeginTransaction()
Dim sqlQ As String = "UPDATE " & My.Settings.JobTb & " SET Status = '10' WHERE JobNumber ='" & betacell & "'"
sqlCommand = New SqlCommand(sqlQ, connection, updateTransaction)
sqlCommand.ExecuteNonQuery()
updateTransaction.Commit()
connection.Close()
SendEmail(My.Settings.emailUsers, "EMAIL TEXT")
Call MoveFiles()
End Sub
I'm all chuffed now as iv also managed to make it look for all files with a .success extension. Now it processes all files and not the one named in the code.
Module Module1
Dim sourceDir As String = My.Settings.watchPath
Dim processedDir As String = My.Settings.processedPath
Private loggerName As String = "EmailReleases"
Public Sub log(ex As Exception)
Console.WriteLine("Error: " & ex.ToString)
End Sub
Public Sub log(ByVal s As String)
Console.WriteLine(DateTime.Now.ToString & " [" & loggerName & "] " & s)
End Sub
Public Sub Main()
Dim inputFiles As String() = Directory.GetFiles(sourceDir, "*.success")
log("Starting processing of .success files in '" & sourceDir & "' ... ")
If (inputFiles.Length > 0) Then
Dim connection As New SqlConnection(My.Settings.connectionString)
connection.Open()
For Each fileName As String In inputFiles
Dim sqlCommand As SqlCommand
Dim fFile As New FileInfo(fileName)
log(" Processing " & fFile.Name)
Dim betacell As String = fFile.Name.Substring(0, fFile.Name.Length - 8)
'Update Status on Database with the use of the Betacell
Dim updateTransaction As SqlTransaction = connection.BeginTransaction()
Dim sqlQ As String = "UPDATE " & My.Settings.JobTb & " SET Status = '10' WHERE JobNumber ='" & betacell & "'"
sqlCommand = New SqlCommand(sqlQ, connection, updateTransaction)
Dim result = sqlCommand.ExecuteNonQuery()
'Email COnfirmation
SendEmail(My.Settings.emailUsers, "EMAIL TEXT")
If (result > 0) Then
'Move the file
fFile.MoveTo(processedDir & fFile.Name)
updateTransaction.Commit() ' make sure to commit only in case moving the file is OK
Else
log("ERROR - Betacell '" & betacell & "' not found in database!")
updateTransaction.Rollback()
End If
Rather than polling a folder (i.e. checking every n seconds whether it has new files) it's much more efficient to have the operating system notify you of changes in that folder. You can do this by creating a FileSystemWatcher. There is an example on MSDN.
However, if you did want to poll a folder, it's actually nice and easy - just wrap the following code in a Timer. Please note I normally code in C#, so apologies if the syntax is not 100%...
Imports System.IO
....
For Each file as String in Directory.GetFiles("C:\SomeFolder")
DoSomethingWithFile (file)
Next

ActiveX calling URL page

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.