I'm working with a VBS1, starting a WScript.Shell, starting another VBS2.
VBS1 is running in a bigger context and I need to keep that proccess running and working, while waiting for the result of my VBS2 (about 20-60sec)
Using Sleep is non-blocking in the script, but is blocking my proccess, so I need another option.
Here's the code I got so far:
strFinalCommand = "wscript.exe " & CStr(ScriptPath) & " " & CStr(strParams)
Set ObjShell = CreateObject("WScript.Shell")
Set ShellExec = ObjShell.Exec(strFinalCommand)
hitTimeout = False
SleepCounter = 0
Do While ShellExec.Status = 0 'WshRunning
ActiveSession.Sleep 100 '--> On changing sleep-duration, please change multiplier in IF below, too
SleepCounter = SleepCounter + 1
If SleepCounter >= TimeoutDuration * 10 Then 'TimeoutDuration * 2
hitTimeout = True
ShellExec.Terminate
Exit Do
End If
Loop
Set ShellExec = Nothing
Set ObjShell = Nothing
If hitTimeout = False Then
ReportSuccess = True
End If
Everything is running fine regarding that script, but other actions running the proccess are blocked.
Can anyone suggest another Sleep, which is non-blocking?
Related
I'm trying to create a script to check if a program (In this case, the calculator) is running or not.
I also don't quite understand why set oExec = script.Exec("calc") would run the program. Thanks in advance :)
set script = wscript.CreateObject("WScript.Shell")
set oExec = script.Exec("calc")
Do While oExec.Status = 0
WScript.Sleep 100
Loop
if oExec.Status = 1 Then
MsgBox("Calculator is open")
WScript.Quit()
End if
Solved my own problem! From this: How to run loop check vbs for particular running process? Or missing process?
Set service = GetObject ("winmgmts:")
For Each Process In Service.InstancesOf("Win32_Process")
If Process.Name = "Calculator.exe" Then
WScript.Echo "Calc is running"
WScript.Quit
End If
Next
I have created a script which checks for the idle time using a program MousePos.exe and pushes the response back to itself to work out whether there has been any mouse movement. This all works fine, however everytime the MousePos.exe runs it flashes on the screen and I want to hide this. I have no idea how to do this, I expected it would be quite simple.
I was advised I need to Use the WshShell object's Run method instead of the WshScriptExec object but I have no idea how to do this and still read in the response from the EXE.
Function execStdOut(cmd)
Dim goWSH : Set goWSH = CreateObject("WScript.Shell")
Dim aRet: Set aRet = goWSH.Exec(cmd)
execStdOut = aRet.StdOut.ReadAll()
End Function
'wait 2 seconds for things to calm now
WScript.Sleep 2000
'get initial Mouse XY
MPOS = execStdOut("cmd /c C:\Windows\MousePos.exe")
WScript.Sleep 10000 '10 seconds
'set initial idle counter
Idle = 0
Do While forever = 0
OLD = MPOS
MPOS = execStdOut("cmd /c C:\Windows\MousePos.exe")
If OLD = MPOS Then
Idle = Idle + 1
If idle = 12 Then '12 x 10 seconds for 2 minute timeout
idle = 0
Set objShell = WScript.CreateObject("WScript.Shell")
objshell.Run "C:\Windows\IERestart_countdown.hta", 1, True
End If
Else
idle = 0
End If
WScript.Sleep 10000 ' 10 seconds
Loop
I'm writing a program to open and run multiple VBA modules on a server to upload new data to the cloud. I need to run the modules every 5 minutes at least (preferably every 2 minutes) without stopping 24/7 for an extended period of time. So far, my code will work for 1000-4000 loops, but fails every 1-4 days. How can I make my program more robust?
I'm pretty new to VBScripts, but have pieced together some code that works pretty well from other examples I've found through my research. I've added some error handling (On Error Resume Next and an error check after each major operation) but there are still occasional errors that sneak through and stop the program.
The errors I've been seeing include "unknown VBA runtime error," permission errors (when opening the local log), and server errors. I've tried to mitigate or ignore these with pings and error handling, but some still manage to stop the code from looping.
I've also tried using the Windows Task Scheduler, but that can only go at most every 5 minutes and I couldn't get it to run reliably.
On Error Resume Next
Set WshShell = CreateObject("WScript.Shell")
Dim objFSO
Dim myLog
Dim myLocalLog
Dim pingResultV
Dim pingResultN
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objExcel = CreateObject("Excel.Application")
objExcel.DisplayAlerts = False
objExcel.Visible = True
Set myLog = objFSO.OpenTextFile("location of log on server", 8)
Set myLocalLog = objFSO.OpenTextFile("location of log on local hard drive", 8)
Dim i
i = 0
Do While i < 1000000
'Ping the server to check if the connection is open
PINGFlagV = Not CBool(WshShell.run("ping -n 1 server",0,True))
pingResultV = "Null"
'if the ping was successful, open each file in sequence and run the VBA modules
If PINGFlagV = True Then
timeStamp = Now()
Set Wb = objExcel.WorkBooks.Open("excel file on server",,True)
objExcel.Application.Run "VBA module to copy data to cloud"
objExcel.Application.Quit
If Err.Number <> 0 Then
myLocalLog.WriteLine(timeStamp & " Error in running VBA Script: " & Err.Description)
Err.Clear
End If
Set Wb2 = objExcel.WorkBooks.Open("second excel file on server",,True)
objExcel.Application.Run "VBA module to copy this data to cloud"
objExcel.Application.Quit
If Err.Number <> 0 Then
myLocalLog.WriteLine(timeStamp & " Error in running VBA Script 2: " & Err.Description)
Err.Clear
End If
'Write to the server log that it succeeded or failed
pingResultV = "Server Ping Success"
myLog.WriteLine(timeStamp & " i=" & i & " --- " & pingResultV)
Else
pingResultV = "Server Ping Failed"
timeStamp = Now()
End If
'Write to a local log whether the server was available or not
myLocalLog.WriteLine(timeStamp & " i=" & i & " --- " & pingResultV)
If Err.Number <> 0 Then
myLog.WriteLine(timeStamp & " Error in writing to local log: " & Err.Description)
Err.Clear
End If
'Time between iterations in milliseconds. 120000 ms = 2 minutes
WScript.Sleep(30000)
i = i + 1
Loop
I'm not asking for someone to overhaul my code, but I would appreciate any suggestions on improvements. I'm also open to methods other than VBScript if they're more robust.
Some additional background on the system that might be helpful: I have 2 computers that upload data to a server every few minutes, but these computers can't be connected to the internet for security reasons. I need to upload the data these computers generate to an internet database every few minutes so it can be accessed remotely. The code I wrote runs on a separate computer that's connected to the server and internet, and it periodically opens the excel files on the server in read-only mode and runs a VBA script that uploads new data lines to the cloud.
It's hard to tell whether your VBScript or your VBA module or both fail. From your error descriptions, I somewhat expect the latter to be the case. So I'd also suggest to check your VBA coda (again). As for this script, one thing I'd suggest to get rid off the permission / log file error would be to move the logging to its own method, e.g.
' *** VBScript (FSO) ***
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
' Log file
Const LOG_FILE = "C:\MyData\MyLog.txt"
Sub WriteLog (ByVal sLogFile, ByVal sText)
Dim oFso
Dim oLogFile
Set oFso = CreateObject("Scripting.FileSystemObject")
Set oLogFile = oFso.OpenTextFile(sLogFile, ForAppending, True)
' Prefix log message with current date/time
sText = Now & " " & sText
oLogFile.WriteLine sText
oLogFile.Close
' Free resources
Set oLogFile = Nothing
Set oFso = Nothing
End Sub
And call it like
If Err.Number <> 0 Then
WriteLog LOG_FILE, "Error in writing to local log: " & CStr(Err.Number) & ", " & Err.Description
Err.Clear
End If
I also suggest to release all resources at the end of the loop, e.g. the Excel object, for which you need to move the object creation into the loop:
Dim i
i = 0
Do While i < 1000000
' Start of loop
Set objExcel = CreateObject("Excel.Application")
objExcel.DisplayAlerts = False
objExcel.Visible = True
' Do your stuff ...
' End of Loop -> free resources
Set Wb = Nothing
Set Wb2 = Nothing
objExcel.WorkBooks.Close
Set objExcel = Nothing
' Time between iterations in milliseconds. 120000 ms = 2 minutes
WScript.Sleep(30000)
i = i + 1
Loop
And as I'm not an Excel expert, I wonder if objExcel.Visible = True does make sense here or if it would better be set to False?
I have on Outlook rule that kicks off a batch statement which starts a VBScript that then kicks off other VBScripts based on the sender and subject heading. If two emails from the same sender come into the in box simultaneously, it will start the first instance correctly. However, the second will kick off and return an error stating "Permission denied". I would like to run each email consecutively.
I have already tried the sleep functions and other time bound delays, but the query times are not consistent due to the size of the data.
Here is the basic script I have been using.
Set olApp = CreateObject("Outlook.Application")
Set olMAPI = olApp.GetNameSpace("MAPI")
Set oFolder = olMAPI.Folders("FieldFinanceAutomatedReports#xxxxx.com").Folders("Inbox").Folders("Requested Report People")
Set allEmails = oFolder.Items
Set firstemail = allEmails.GetLast
unreadCount = 0
For Each email In oFolder.Items
If email.Unread = True Then
If email.Sender= "Sender_of_email#email.com" Then
Set objcreate = CreateObject("Scripting.FileSystemObject")
Set objread = objcreate.OpenTextFile("C:\path_to_script\script.vbs")
request = objread.ReadAll()
objread.Close
Set objread = Nothing
Execute request
Set request = Nothing
Set objcreate = Nothing
End If
WScript.Sleep 500
If email.Sender = "Another_Sender_of_email#email.com" Then
Set objcreate = CreateObject("Scripting.FileSystemObject")
Set objread = objcreate.OpenTextFile("C:\path_to_script\another_script.vbs")
another_request = objread.ReadAll()
objread.Close
Set objread = Nothing
Execute another_request
Set another_request = Nothing
Set objcreate = Nothing
End If
WScript.Sleep 500
unreadCount = unreadCount + 1
End If
Next
I would like for each of the instances to wait until it the first process is complete.
What you need is called a semaphore or mutex. Essentially that's a resource that can be held by only one process or thread at a time. In VBScript you could implement that by attempting to create a (temporary) file. First process to do that wins, subsequent attempts will fail because the file already exists.
Set sh = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
filename = sh.ExpandEnvironmentStrings("%TEMP%\mutex.txt")
'this will throw an error if the file is already opened
Set f = fso.OpenTextFile(filename, 2, True)
Note that you need to open the file for writing (second parameter set to 2). Opening it for reading (second parameter set to 1) does not suffice.
Run the operation in a loop and you can wait for another process to finish and release the mutex.
Set sh = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
filename = sh.ExpandEnvironmentStrings("%TEMP%\mutex.txt")
On Error Resume Next
Do
Err.Clear
Set f = fso.OpenTextFile(filename, 2, True)
If Err Then WScript.Sleep 100
Loop While Err
On Error Goto 0
Make sure you remove the file when your script leaves the critical section (or terminates), otherwise other scripts might have trouble acquiring the mutex later. A convenient way of doing this is to implement the mutex as a class. That way it will automatically be cleaned up, even if the script should terminate unexpectedly.
Class Mutex
Private f_
Private Sub Class_Initialize
Set sh = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
filename = sh.ExpandEnvironmentStrings("%TEMP%\mutex.txt")
On Error Resume Next
Do
Err.Clear
Set f_ = fso.OpenTextFile(filename, 2, True)
If Err Then WScript.Sleep 100
Loop While Err
On Error Goto 0
End Sub
Private Sub Class_Terminate
f_.Close
End Sub
End Class
You use that Mutex class in your code like this:
Set m = New Mutex 'acquire mutex
'...
'critical section goes here
'...
Set m = Nothing 'release mutex
IMPORTANT UPDATE:
As Cheran S stated below, it's a good idea to avoid using "taskmgr" for this script. I'm not going to edit the code, as I feel it's best to maintain the original question as much as possible since doing so would partially invalidate & obfuscate Cheran's answer & comment.
A good alternative to "taskmgr" would be "CharMap" (for simple & fast testing).
Running Windows XP Professional (32-bit) and I've got this script that's throwing up this error:
Script: C:\test.vbs
Line: 40
Char: 3
Error: 0x80041017
Code: 80041017
Source: (null)
Here's the code:
Set objWshShell = Wscript.CreateObject("Wscript.Shell")
Set objWshNet = CreateObject("Wscript.Network")
strComputer = objWshNet.ComputerName
Set objWMIService = GetObject("winmgmts:" & _
"{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Dim arrWinTitle(2)
arrWinTitle(0) = "My Documents"
arrWinTitle(1) = "Control Panel"
Dim arrProcName(3)
arrProcName(0) = "'taskmgr.exe'"
arrProcName(1) = "'calc.exe'"
arrProcName(2) = "'notepad.exe'"
Sub srBlockWindow(strWinTitle, intWinTitle, strProcName, intProcName)
i = 0
Do While i = 0
If objWshShell.AppActivate(strWinTitle(intWinTitle)) Then
objWshShell.AppActivate(strWinTitle(intWinTitle))
Wscript.Sleep 100
objWshShell.SendKeys "%{F4}"
Wscript.Sleep 100
End If
If intWinTitle = 0 Then
intWinTitle = intWinTitle + 1
Else
intWinTitle = 0
End If
Wscript.Sleep 100
Set colProcesses = objWMIService.ExecQuery _
("SELECT * FROM Win32_Process WHERE NAME = " & strProcName(intProcName))
For Each objProcess In colProcesses
objProcess.Terminate()
Next
If intProcName >= 0 Then
intProcName = intProcName + 1
ElseIf intProcName >= 5 Then
intProcName = 0
End If
Set colProcesses = Nothing
Loop
End Sub
Call srBlockWindow(arrWinTitle, 0, arrProcName, 0)
I've reviewed this, but I believe my script doesn't have any issues with the quotes. For the sake of clarity, I'm getting the error at the start of the "For Each ..." string.
What's peculiar is that it will run fine the first time, but once it loops, that's when I get the error. So, it will close all the desired Windows/Applications, but once it goes through it's second iteration, I get the error. I've inserted "On Error Resume Next", but that doesn't resolve it (I will add it later, since it's required to resolve the conflict when the Window/Process Starts simultaneously with Close/End/Stop attempts made by the Script).
I think it's because I should be conditionally checking if the process exists; problem is, I'm not quite sure how to do that with this code (I've never been good with Collections). Anybody have suggestions on how to do it with this code specifically?
I reviewed this and tried to write a quick alternative script, but it didn't really work. Here's the code:
Set service = GetObject("winmgmts:")
Dim arrProcName(3)
arrProcName(0) = "'taskmgr.exe'"
arrProcName(1) = "'calc.exe'"
arrProcName(2) = "'notepad.exe'"
Sub srTest(strProc, intProc)
i = 0
Do While i = 0
For Each Process In Service.InstancesOf("Win32_Process")
If Process.Name = strProc(intProc) Then
Process.Name.Terminate
Process.Terminate
End If
Next
If intProc = 0 Then
intProc = intProc + 1
ElseIf intProc >= 3 Then
intProc = 0
End If
Loop
End Sub
Call srTest(arrProcName, 0)
As you can see, I tried both "Process.Terminate" & "Process.Name.Terminate", but neither yielded anything (not even an error). I further tested it with "Wscript.Echo Process.Name" & "Wscript.Echo strProc(intProc)", but neither of these worked too.
Now that I've failed at this alternative solution, I'm feeling that I'm wildly stabbing in the dark for solutions, so I'll defer these esoteric challenges to the community that is vastly superior to me.
There might be a few here who are reading this and wondering why I'm targeting My Documents, Control Panel, taskmgr.exe, calc.exe, & notepad.exe. Almost everybody reading this will probably be able to extrapolate on their own, but I'll make sure I'm clear on this for those who need it. I'm doing this because it makes it easier to test, since all of these can be accessed simply by using the "Run" shortcut (Windows Key + R) & then entering the following strings (one at a time, of course):
My Documents
Control
taskmgr
calc
notepad
You likely knew the keywords, but I just wanted to highlight why I'm using these specific ones (speed & simplicity).
I'll remove this if Cheran adds the final code to the answer posted
Final Solution:
Set objWshShell = Wscript.CreateObject("Wscript.Shell")
Set objWshNet = CreateObject("Wscript.Network")
strComputer = objWshNet.ComputerName
Set objWMIService = GetObject("winmgmts:" & _
"{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Dim arrWinTitle
arrWinTitle = Array("My Documents", "Control Panel")
Dim arrProcName
arrProcName = Array("'charmap.exe'", "'calc.exe'", "'notepad.exe'")
Sub srBlockWindow(strWinTitle, intWinTitle, strProcName, intProcName)
i = 0
Do While i = 0
On Error Resume Next
' In the Event of Conflict w/Initiation of Window or Process
If objWshShell.AppActivate(strWinTitle(intWinTitle)) Then
objWshShell.AppActivate(strWinTitle(intWinTitle))
Wscript.Sleep 100
objWshShell.SendKeys "%{F4}"
Wscript.Sleep 100
End If
intWinTitle = (intWinTitle + 1) Mod (UBound(strWinTitle) + 1)
Wscript.Sleep 100
Set colProcesses = objWMIService.ExecQuery _
("SELECT * FROM Win32_Process WHERE NAME = " & strProcName(intProcName))
For Each objProcess In colProcesses
objProcess.Terminate()
Next
intProcName = (intProcName + 1) Mod (UBound(strProcName) + 1)
Set colProcesses = Nothing
Loop
End Sub
Call srBlockWindow(arrWinTitle, 0, arrProcName, 0)
Here's a quick script I threw together to test it against:
Set objWshShell = Wscript.CreateObject("Wscript.Shell")
i = 0
Do While i = 0
objWshShell.Run "explorer.exe /e, C:\Documents and Settings\User\My Documents"
Wscript.Sleep 200
objWshShell.Run "CharMap.exe"
Wscript.Sleep 200
objWshShell.Run "Control.exe"
Wscript.Sleep 200
objWshShell.Run "calc.exe"
Wscript.Sleep 200
objWshShell.Run "notepad.exe"
Wscript.Sleep 200
Loop
BE CAREFUL! Adjust the timings so that you can end "Wscript.exe" without too many problems. Best to run both scripts simultaneously to see how it works.
Two big issues I found:
The main problem here is in the way you define your arrays. The number you specify in the array declaration is the largest array subscript. Since VBScript arrays are always indexed starting at 0, you actually need to specify one less than the number of elements in the array.
' This is wrong:
Dim arrWinTitle(2)
Dim arrProcName(3)
' Should be:
Dim arrWinTitle(1)
Dim arrProcName(2)
You could also use the Array function to initialize your array, assuming that you know beforehand how many elements are in it. In that case, you would just declare arrWinTitle as a Variant and not as an array:
Dim arrWinTitle
arrWinTitle = Array("My Documents", "Control Panel")
If you make that change and try to run the script, you'll still get a "Subscript out of range" error. That error is caused by this block:
If intProcName >= 0 Then
intProcName = intProcName + 1
ElseIf intProcName >= 5 Then
intProcName = 0
End If
First off, the maximum subscript should be 2 for strProcName, and not 5. Even then, this code won't work. It seems like what you're trying to do is loop through the elements of array, then start over back at 0. A better of doing this is with the Mod operator:
intProcName = (intProcName + 1) Mod (UBound(strProcName) + 1)
Notice also how I use the UBound function to avoid hard-coding the actual length of the array.
I won't spend too much time analyzing your second example, since it was just an attempt to make the first example work. I will note, however, that in your arrProcName array, the process names still have the single quotes around them, which is one reason why that script didn't work either.