I'm trying to monitor a specific folder, for a file creation using VBS.
This is the monitor creation function of the folder, as I've seen in many examples:
Function CreateMonitor(path)
Set wmi = GetObject("winmgmts://./root/cimv2")
Set fso = CreateObject("Scripting.FileSystemObject")
path = Split(fso.GetAbsolutePathName(path), ":")
drv = path(0) & ":"
dir = Replace(path(1), "\", "\\")
If Right(dir, 2) <> "\\" Then dir = dir & "\\"
query = "SELECT * FROM __InstanceOperationEvent" & _
" WITHIN " & Interval & _
" WHERE Targetinstance ISA 'CIM_DataFile'" & _
" AND TargetInstance.Drive='" & drv & "'" & _
" AND TargetInstance.Path='" & dir & "'"
Set CreateMonitor = wmi.ExecNotificationQuery(query)
End Function
Then I save it to the following var:
Set monitor = CreateMonitor(FolderPath)
Eventually I use the following loop which will run endlessly (monitor) and will create an instance when a file in the folder was created :
Do
Set evt = monitor.NextEvent()
Select Case evt.Path_.Class
Case "__InstanceCreationEvent"
Call SendNotification (evt.TargetInstance)
End Select
Loop
After a successful monitoring process creation I'm willing to move further with the file that has been created and send it to "SendNotification" function.
The problem is that the calling of the function doesn't occurs and I'm finding myself stuck in the loop without entering this function. It waits until a file is being created and only then proceed further.
What am I doing wrong? Whats is the proper way for a function call in this case?
Return value If the NextEvent method is successful, it returns an SWbemObject object that contains the requested event. If the call
times out, the returned object is NULL and an error is raised.
Error codes Upon the completion of the NextEvent method, the Err object may contain the error code in the following list.
wbemErrTimedOut - 0x80043001 Requested event did not arrive in the amount of time specified in iTimeoutMs
https://msdn.microsoft.com/en-us/library/aa393711(v=vs.85).aspx
Said that, I would try If evt Is Nothing Then Exit Loop as follows
Do
Set evt = monitor.NextEvent()
If evt Is Nothing Then Exit Do
Select Case evt.Path_.Class
Case "__InstanceCreationEvent"
call SendNotification (evt.TargetInstance)
End Select
Loop
Or
On Error Resume Next
Do
Set evt = monitor.NextEvent()
If Err <> 0 Then
If Err.Number = wbemErrTimedout Then ' = &H80043001
Exit Do
Select Case evt.Path_.Class
Case "__InstanceCreationEvent"
call SendNotification (evt.TargetInstance)
End Select
Loop
I have a VBS script (compiled to an .exe, actually) that invokes another program (.exe) using the VBS Run instruction. My mainframe mentality tells me that it would be beneficial to pre-load this second program at the start of my script, so that it is available immediately when needed further down the line. Typically on mainframe, when appropriate, one would LOAD the program into memory at some point and then branch to it later.
Does this concept exist in VBS?
Thanks for any advice.
It is easy to start a program in a suspended state, but I have still not found a way to later resume the execution without a external tool (we need to call ResumeThread API). For this sample I have used the Windows SysInternal's PsSuspend tool to resume the process.
Option Explicit
Const SW_NORMAL = 1
Const CF_CREATE_SUSPENDED = 4
Const PROCESS_NAME = "Notepad.exe"
' Instantiate required objects
Dim wmi, shell
Set wmi = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set shell = WScript.CreateObject("WScript.Shell")
' Prepare the startup configuration for the process
' https://msdn.microsoft.com/en-us/library/aa394375%28v=vs.85%29.aspx
Dim startUp
Set startUp = wmi.Get("Win32_ProcessStartup").SpawnInstance_
With startUp
.ShowWindow = SW_NORMAL
.CreateFlags = CF_CREATE_SUSPENDED
End With
' Start the process
' https://msdn.microsoft.com/en-us/library/aa394372%28v=vs.85%29.aspx
Dim retCode, processID
retCode = wmi.Get("Win32_Process").Create( PROCESS_NAME, Null, startUp, processID )
If retCode <> 0 Then
Wscript.Echo "Process creation failed: " & retCode
WScript.Quit 1
End If
WScript.Echo "Process created with PID: " & processID
' Ask the OS to check for presence of our process
WScript.Echo shell.Exec("tasklist /fo:list /v /fi ""imagename eq " & PROCESS_NAME & """").StdOut.ReadAll()
' Wait (not required, just for testing)
WScript.Sleep 5000
' Resume the process - SysInternals pssuspend required
' https://technet.microsoft.com/en-us/sysinternals/pssuspend.aspx
Call shell.Run("pssuspend64.exe /accepteula -r " & processID, 0, False)
' Wait for the process to resume and show again the task list
WScript.Sleep 2000
WScript.Echo shell.Exec("tasklist /fo:list /v /fi ""imagename eq " & PROCESS_NAME & """").StdOut.ReadAll()
I am attempting to close a shell Chrome window via a VBA function. My function runs a URL query that returns a .csv file. The thing is I would like to close the window so that it is not always showing (This process runs every 3 minutes). I haven't been able to find a solution that I can get to work as of yet. I tried adding SendKeys "%{F4}" after as one site suggested. This merely minimizes the window, not close it. I also attempted to try adding DoCmd.Close Shell, "Untitled" after, yet this also did not work. I have spent several hours attempting to do, what I imagine is a simple task, and felt another set of eyes could point me in the right direction. Below is my code that opens Chrome. Any assistance is greatly appreciated.
Public Function RunYahooAPI()
Dim chromePath As String
chromePath = """C:\Program Files\Google\Chrome\Application\chrome.exe"""
Shell (chromePath & " -url http://download.finance.yahoo.com/d/quotes.csv?s=CVX%2CXOM%2CHP%2CSLB%2CPBA%2CATR%2CECL%2CNVZMY%2CMON&f=nsl1op&e=.csv")
End Function
this VBA code will launch (as in your question) chrome, save the Process handle in the variable pHandle, loop all processes with this Handle and then stop the process (after checking user and domain of the process owner) .
Sub LaunchandStopProcess()
'
' As in your Question
'
Dim chromePath As String
Dim pHandle As Variant
chromePath = "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe"
'
' Note: Shell pass the Process Handle to the PID variable
'
PHandle = Shell(chromePath & " -url http://download.finance.yahoo.com/d/quotes.csv?s=CVX%2CXOM%2CHP%2CSLB%2CPBA%2CATR%2CECL%2CNVZMY%2CMON&f=nsl1op&e=.csv")
Dim objWMIcimv2 As Object
Dim objProcess As Object
Dim objList As Object
Dim ProcToTerminate As String
Dim intError As Integer
Set objWMIcimv2 = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objList = objWMIcimv2.ExecQuery("select * from win32_process where Handle='" & CStr(pHandle) & "'")
'
' ObjList contains the list of all process matching the Handle (normally your chrome App, if running)
'
If objList.Count = 0 Then
' No matching Process
' Set all objects to nothing
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Exit Sub
Else
'
' Parse all matching Processes
'
For Each objProcess In objList
' additionally check with actual user
colProperties = objProcess.getowner(strNameofUser, strUserdomain)
If strUserdomain + "\" + strNameofUser = Environ$("userdomain") + "\" + Environ$("username") Then
intError = objProcess.Terminate
If intError <> 0 Then
'
' Trap Error or do nothing if code run unattended
'
Else
' Confirm that process is killed or nothing if code run unattended
End If
End If
Next
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
End If
End Sub
I'm using the following code snippet to determine what process ID my vbscript is running as:
On Error Resume Next
Dim iMyPID : iMyPID = GetObject("winmgmts:root\cimv2").Get("Win32_Process.Handle='" & CreateObject("WScript.Shell").Exec("mshta.exe").ProcessID & "'").ParentProcessId
If Err.Number <> 0 Then Call Handle_Error(Err.Description)
On Error Goto 0
On my Windows 7 (32-bit) machine this works about 90% of the time and iMyPID contains the process ID of the currently running script. However 10% of the time Handle_Error gets called with the error message "SWbemServicesEX: Not found".
Recently someone else running Windows 7 (64-bit) reported that Handle_Error always gets called with the error message "Out of memory". This seems an insane error message just to find out your own process ID!
Can anyone recommend a better way of doing this?
mshta terminates itself immediately. Maybe it's too late to achieve parent process id by using WMI service.
So, I'd use something like this to eliminate concurrent script processes.
Generate random things.
Determine an application which could be installed on each system, never terminates by itself (e.g. command prompt with /k parameter).
Start the application in hidden mode with generated random argument (WshShell.Run).
Wait a few milliseconds
Query the running processes by using command line argument value.
Get the ParentProcessId property.
Function CurrProcessId
Dim oShell, sCmd, oWMI, oChldPrcs, oCols, lOut
lOut = 0
Set oShell = CreateObject("WScript.Shell")
Set oWMI = GetObject(_
"winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
sCmd = "/K " & Left(CreateObject("Scriptlet.TypeLib").Guid, 38)
oShell.Run "%comspec% " & sCmd, 0
WScript.Sleep 100 'For healthier skin, get some sleep
Set oChldPrcs = oWMI.ExecQuery(_
"Select * From Win32_Process Where CommandLine Like '%" & sCmd & "'",,32)
For Each oCols In oChldPrcs
lOut = oCols.ParentProcessId 'get parent
oCols.Terminate 'process terminated
Exit For
Next
CurrProcessId = lOut
End Function
Dim ProcessId
ProcessId = CurrProcessId 'will remain valid indefinitely
WScript.Echo ProcessId
Here's an even better code snippet:
' ***********************************************************************************************************
' lng_MyProcessID finds and returns my own process ID. This is excruciatingly difficult in VBScript. The
' method used here forks "cmd /c pause" with .Exec, and then uses the returned .Exec object's .ProcessID
' attribute to feed into WMI to get that process's Win32_Process descriptor object, and then uses THAT
' WMI Win32_Process descriptor object's .ParentProcessId attribute, which will be OUR Process ID, and finally
' we terminate the waiting cmd process. Execing cmd is what causes the brief cmd window to flash at start up,
' and I can' figure out out how to hide that window.
' returns: My own Process ID as a long int; zero if we can't get it.
' ************************************************************************************************************
Function lng_MyProcessID ()
lng_MyProcessID = 0 ' Initially assume failure
If objWMIService Is Nothing Then Exit Function ' Should only happen if in Guest or other super-limited account
Set objChildProcess = objWshShell.Exec ( """%ComSpec%"" /C pause" ) ' Fork a child process that just waits until its killed
Set colPIDs= objWMIService.ExecQuery ( "Select * From Win32_Process Where ProcessId=" & objChildProcess.ProcessID,, 0 )
For Each objPID In colPIDs ' There's exactly 1 item, but .ItemIndex(0) doesn't work in XP
lng_MyProcessID = objPID.ParentProcessId ' Return child's parent Process ID, which is MY process ID!
Next
Call objChildProcess.Terminate() ' Terminate our temp child
End Function ' lng_MyProcessID
I like Kul-Tigin's idea (+1), and Asok Smith's idea (based on .Exec) deserve respect (+1), and it w'd been even better if .Exec run hidden process. So, to feed my curiosity, I also toyed with this and this's what I did.
ts1 = Timer : res1 = CurrProcessId : te1 = Timer - ts1
ts2 = Timer : res2 = ThisProcessId : te2 = Timer - ts2
WScript.Echo "CurrProcessId", res1, FormatNumber(te1, 6), _
vbCrLf & "ThisProcessId", res2, FormatNumber(te2, 6), _
vbCrLf & "CurrProcessId / ThisProcessId = " & te1 / te2
'> CurrProcessId 6946 0,437500
'> ThisProcessId 6946 0,015625
'> CurrProcessId / ThisProcessId = 28
Function ThisProcessId
ThisProcessId = 0
Dim sTFile, oPrc
With CreateObject("Scripting.FileSystemObject")
sTFile = .BuildPath(.GetSpecialFolder(2), "sleep.vbs")
With .OpenTextFile(sTFile, 2, True)
.Write "WScript.Sleep 1000"
End With
End With
With CreateObject("WScript.Shell").Exec("WScript " & sTFile)
For Each oPrc In GetObject("winmgmts:\\.\root\cimv2").ExecQuery(_
"Select * From Win32_Process Where ProcessId=" & .ProcessID)
Exit For : Next
ThisProcessId = oPrc.ParentProcessId
End With
End Function
28 times faster(!), not bad :)
You may use Sleep from kernel32 instead of mshta.
MsgBox GetProcId()
Function GetProcId()
With GetObject("winmgmts:\\.\root\CIMV2:Win32_Process.Handle='" & CreateObject("WScript.Shell").Exec("rundll32 kernel32,Sleep").ProcessId & "'")
GetProcId = .ParentProcessId
.Terminate
End With
End Function
Code taken from here.
Also there is parent process name detection based on this approach.
Here is a better one, but in JScript (sorry, you translate it to VB ...)
var WshShell = WScript.CreateObject("WScript.Shell");
var objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\\\.\\root\\cimv2");
var childProcess =
WshShell.Exec
(
'"' + WshShell.Environment('PROCESS')('ComSpec') + '"'
+
" /C Echo \"Text lines\" && Set /p VarName="
);
childProcess.StdOut.ReadLine();
var current_pid =
objWMIService.ExecQuery
(
"Select * From Win32_Process Where ProcessId=" + childProcess.ProcessID
);
current_pid = (new Enumerator(current_pid)).item().ParentProcessId;
if (current_pid)
{
childProcess.StdIn.WriteLine("value"); // child process should now exit
WScript.Echo("Current PID: " + current_pid);
}
else
{
WScript.StdErr.WriteLine("Get current PID from WMI failed.");
WScript.Quit(7);
}
I just found this thread that partly solved my problem.
Thank you all.
"the code is unable to determine which process ID belongs to which script" : true, but as this is the first task that your script must achieve , you can keep the Pid that has the shortest lifetime.
Set com = CreateObject("Wscript.Shell")
Set objSWbemServices = GetObject ("WinMgmts:Root\Cimv2")
Set colProcess = objSWbemServices.ExecQuery ("Select * From Win32_Process")
dim toto, thisPid
thisPid=""
toto=200 ' just a high value like 200sec
For Each objProcess In colProcess
If InStr (objProcess.CommandLine, WScript.ScriptName) <> 0 Then
Ptime=((Cdbl(objProcess.UserModeTime)+Cdbl(objProcess.KernelModeTime))/10000000)
if toto > Ptime then
toto = Ptime
thisPid = objProcess.ProcessId
End If
End If
Next
If thisPid="" then
WScript.Echo "unable to get the PID"
Else
WScript.Echo "PID of this script : "&thisPid
End If
Except if you fired scripts quicker more than each one can retrieve their Pid, everything must be ok.
To retrieve the own process ID of a VB Script you can rely on the property CreationDate of the Process object.
At the moment a VB Script is started, the process that runs the script will have the latest CreationDate of all processes that runs the same script.
In fact, it will have the highest CreationDate of all running processes.
So, to get the PID, first thing to do is to search for the process with the highest CreationDate.
'Searching for processes
Dim strScriptName
Dim WMI, wql
Dim objProcess
'
'My process
Dim datHighest
Dim lngMyProcessId
'Which script to look for ?
strScriptName = "WScript.exe"
'strScriptName = "Notepad.exe"
'Iniitialise
datHighest = Cdbl(0)
Set WMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
wql = "SELECT * FROM Win32_Process WHERE Name = '" & strScriptName & "'"
'
For Each objProcess In WMI.ExecQuery(wql)
'The next If is not necessary, it only restricts the search to all processes on the current VB Script
'If Instr(objProcess.CommandLine, WScript.ScriptName) <> 0 Then
If objProcess.CreationDate > datHighest Then
'Take the process with the highest CreationDate so far
' e.g. 20160406121130.510941+120 i.e. 2016-04-06 12h11m:30s and fraction
datHighest = objProcess.CreationDate
lngMyProcessId = objProcess.ProcessId
End If
'End If
Next
'Show The result
WScript.Echo "My process Id = " & lngMyProcessId
Powershell can be used to retrieve the calling VBScript process ID. This approach utilizes the optional argument of the exit command which specifies the program's exit code. And, if the optional 3rd argument of the WShell.Run method is set to True, then it will return the exit code (which is the VBScript process ID) after powershell has closed.
Dim sCmd
Dim WShell
sCmd = _
"powershell -command exit " & _
"(gwmi Win32_Process -Filter " & _
"\""processid='$PID'\"").parentprocessid"
Set WShell = CreateObject("WScript.Shell")
MsgBox WShell.Run(sCmd, 0, True)
This is not my answer, I found this in some google groups discussion forum... See if it helps you.
Set objSWbemServices = GetObject ("WinMgmts:Root\Cimv2")
Set colProcess = objSWbemServices.ExecQuery ("Select * From Win32_Process")
For Each objProcess In colProcess
If InStr (objProcess.CommandLine, WScript.ScriptName) <> 0 Then
WScript.Echo objProcess.Name, objProcess.ProcessId, objProcess.CommandLine
End If
Next
Original Discussion Thread in Google Groups forum
Get the current processID
Set WshShell = CreateObject("WScript.Shell")
currentProgram=wscript.ScriptName
Const strComputer = "."
Dim objWMIService, colProcessList
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
query="SELECT * FROM Win32_Process WHERE Name = 'wscript.exe' "
Set colProcessList = objWMIService.ExecQuery(query)
For Each objProcess in colProcessList
If (InStr (objProcess.commandLine,wscript.ScriptName) <> 0 )Then
processDetails="Current ProcessId : "& objProcess.ProcessId & " \n, And Process Name:" & objProcess.name &"\n CommandLine is :"& objProcess.CommandLine
message = msgbox(processDetails,16,"Details")
End If
I used this to get a scripts own process id.
Function GetPid()
GetPid=GetObject("winmgmts:\\.\root\CIMV2").ExecQuery("Select * From Win32_Process Where CommandLine Like '%" &Wscript.ScriptName& "%'").ItemIndex(0).ProcessId
End Function
Wscript.Echo GetPid()
I am a newbie to VBS scripting. I am getting above error on line 54, character 5 in script below. This error says "Object doesn't support this property or method: 'MimeMapArray'".
And line it is referring to is:
MimeMapArray(i) = CreateObject("MimeMap")
Can u tell me what I am doing wrong? Here is the script in its entirety. Note, I am trying to run this on an XP OS by double-clicking this VBS file.
' This script adds the necessary Windows Presentation Foundation MIME types
' to an IIS Server.
' To use this script, just double-click or execute it from a command line.
' Running this script multiple times results in multiple entries in the IIS MimeMap.
' Set the MIME types to be added
Dim MimeMapObj
Dim MimeMapArray
Dim WshShell
Dim oExec
Const ADS_PROPERTY_UPDATE = 2
Dim MimeTypesToAddArray
MimeTypesToAddArray = Array(".manifest", "application/manifest", ".xaml", _
"application/xaml+xml", ".application", "application/x-ms-application", _
".deploy", "application/octet-stream", ".xbap", "application/x-ms-xbap", _
".xps", "application/vnd.ms-xpsdocument")
' Get the mimemap object
Set MimeMapObj = GetObject("IIS://LocalHost/MimeMap")
' Call AddMimeType for every pair of extension/MIME type
For counter = 0 to UBound(MimeTypesToAddArray) Step 2
AddMimeType MimeTypesToAddArray(counter), MimeTypesToAddArray(counter+1)
Next
' Create a Shell object
Set WshShell = CreateObject("WScript.Shell")
' Stop and Start the IIS Service
Set oExec = WshShell.Exec("net stop w3svc")
Do While oExec.Status = 0
WScript.Sleep 100
Loop
Set oExec = WshShell.Exec("net start w3svc")
Do While oExec.Status = 0
WScript.Sleep 100
Loop
Set oExec = Nothing
' Report status to user
WScript.Echo "Windows Presentation Foundation MIME types have been registered."
' AddMimeType Sub
Sub AddMimeType(ByVal Ext, ByVal MType)
' Get the mappings from the MimeMap property.
MimeMapArray = MimeMapObj.GetEx("MimeMap")
' Add a new mapping.
i = UBound(MimeMapArray) + 1
ReDim Preserve MimeMapArray(i)
MimeMapArray(i) = CreateObject("MimeMap")
MimeMapArray(i).Extension = Ext
MimeMapArray(i).MimeType = MType
MimeMapObj.PutEx ADS_PROPERTY_UPDATE, "MimeMap", MimeMapArray
MimeMapObj.SetInfo()
End Sub
The first thing I can suggest is use cscript to execute. You can get more information that won't go away like with a message box.
Open a command prompt (go to start,
run, type CMD).
Go to the location where your script
is and type the following:
cscript scriptname.vbs
...where scriptname.vbs is the name of your script.
Second, you appear to be missing the "set" in front of your createobject line. Have a look here for reference.
That line should look like:
set MimeMapArray(i) = CreateObject("MimeMap")