I need a VBScript that will check if a process is in use by a specific user:
Agent clicks program icon --> batch file calls for progcheck.vbs -->
progcheck.vbs looks to see is "whatever.exe" is running under that user only -->
if program is running under that user then MsgBox "Program running" --> wscript.quit (this needs to terminate out of the batch file)
else --> return to batch file.
I have tried this with tasklist in a batch file and the script works, but takes forever to run for a domain user. Want to do this in vbscript anyway.
*** UPDATED SCRIPT WITH MODS 10/12 *****
OPTION EXPLICIT
DIM strComputer,strProcess, strUserName,wshShell
Set wshShell = WScript.CreateObject( "WScript.Shell" )
strUserName = wshShell.ExpandEnvironmentStrings( "%USERNAME%" )
strComputer = "." '
strProcess = "notepad.exe"
IF isProcessRunning(strComputer,strProcess,strUserName) THEN
If MsgBox ("Notepad needs to be closed.", 1) = 1 then
wscript.Quit(1)
End If
END IF
FUNCTION isProcessRunning(BYVAL strComputer,BYVAL strProcessName,BYVAL strUserName)
DIM objWMIService, strWMIQuery
strWMIQuery = "Select * from Win32_Process where name like '" & strProcessName & "' AND owner like '" &strUserName& "'"
SET objWMIService = GETOBJECT("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
IF objWMIService.ExecQuery(strWMIQuery).Count > 0 THEN
isProcessRunning = TRUE
ELSE
isProcessRunning = FALSE
END If
End Function
Let me know what you think and where I have it wrong. Thanks in advance.
UPDATED CODE v3: review comments for help
OPTION EXPLICIT
DIM strComputer, strProcess, strUserName, wshShell
Set wshShell = WScript.CreateObject( "WScript.Shell" )
strUserName = wshShell.ExpandEnvironmentStrings( "%USERNAME%" )
strComputer = "."
strProcess = "notepad.exe" 'change this to whatever you are trying to detect
IF isProcessRunning(strComputer, strProcess, strUserName) THEN
If MsgBox ("Notepad needs to be closed.", 1) = 1 then
wscript.Quit(1) 'you need to terminate the process if that's your intention before quitting
End If
Else
msgbox ("Process is not running") 'optional for debug, you can remove this
END IF
FUNCTION isProcessRunning(ByRef strComputer, ByRef strProcess, ByRef strUserName)
DIM objWMIService, strWMIQuery, objProcess, strOwner, Response
strWMIQuery = "SELECT * FROM Win32_Process WHERE NAME = '" & strProcess & "'"
SET objWMIService = GETOBJECT("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2").ExecQuery(strWMIQuery)
IF objWMIService.Count > 0 THEN
msgbox "We have at least ONE instance of Notepad"
For Each objProcess in objWMIService
Response = objProcess.GetOwner(strOwner)
If Response <> 0 Then
'we didn't get any owner information - maybe not permitted by current user to ask for it
Wscript.Echo "Could not get owner info for process [" & objProcess.Name & "]" & VBNewLine & "Error: " & Return
Else
Wscript.Echo "Process [" & objProcess.Name & "] is owned by [" & strOwner & "]" 'for debug you can remove it
if strUserName = strOwner Then
msgbox "we have the user who is running notepad"
isProcessRunning = TRUE
Else
'do nothing as you only want to detect the current user running it
isProcessRunning = FALSE
End If
End If
Next
ELSE
msgbox "We have NO instance of Notepad - Username is Irrelevant"
isProcessRunning = FALSE
END If
End Function
You can use the following function:
FUNCTION isProcessRunning(BYVAL strComputer,BYVAL strProcessName)
DIM objWMIService, strWMIQuery
strWMIQuery = "Select * from Win32_Process where name like '" & strProcessName & "'"
SET objWMIService = GETOBJECT("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
IF objWMIService.ExecQuery(strWMIQuery).Count > 0 THEN
isProcessRunning = TRUE
ELSE
isProcessRunning = FALSE
END IF
END FUNCTION
For local computer you would use "."
For the process name, you would use the executable "notepad.exe"
For the rest of the code, you could can use something simple:
OPTION EXPLICIT
DIM strComputer,strProcess
strComputer = "." ' local computer
strProcess = "notepad.exe" 'whatever is the executable
IF isProcessRunning(strComputer,strProcess) THEN
'do something
ELSE
'do something else or nothing
wscript.echo strProcess & " is NOT running on computer '" & strComputer & "'"
END IF
That should do it.
EXTRA
To show every process running, then just run:
Option Explicit
Dim objWMIService, objProcess, colProcess
Dim strComputer, strList
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
Set colProcess = objWMIService.ExecQuery _
("Select * from Win32_Process")
For Each objProcess in colProcess
strList = strList & vbCr & _
objProcess.Name
Next
WSCript.Echo strList
WScript.Quit
in terminal server this function can be very slow, all the GetOwner calls are terrible in performance.
A very fast solution i created is to narrow the query using SessionID of the current user (assuming we want only current user's processes) So I added this code:
SessionID can be obtained this way:
Dim oExec, sOutput, iUserPos, iUserLen, iStatePos, SessionID
dim oShell, userName
Set oShell = CreateObject("Wscript.Shell")
userName = oShell.ExpandEnvironmentStrings("%USERNAME%")
Set oExec = oShell.Exec("query session %username%")
sOutput = LCase(oExec.StdOut.ReadAll)
iUserPos = InStr(sOutput, LCase(userName))
iStatePos = InStr(sOutput, "active")
iUserLen = Len(userName)
SessionID = CInt(Trim(Mid(sOutput, iUserPos+iUserLen, iStatePos-iUserPos-iUserLen)))
Changed the function from the previous post:
Function isProcessRunning(ByRef strComputer, ByRef strProcess, ByRef strUserName, byRef sessionID)
DIM objWMIService, strWMIQuery, objProcess, strOwner, Response
strWMIQuery = "SELECT * FROM Win32_Process WHERE SessionId = " & sessionID & " And NAME = '" & strProcess & "'"
SET objWMIService = GETOBJECT("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2").ExecQuery(strWMIQuery)
IF objWMIService.Count > 0 THEN
'msgbox "We have at least ONE instance of Notepad"
For Each objProcess in objWMIService
Response = objProcess.GetOwner(strOwner)
If Response = 0 Then
'Wscript.Echo "Process [" & objProcess.Name & "] is owned by [" & strOwner & "]" 'for debug you can remove it
if strUserName = strOwner Then
'msgbox "we have the user who is running notepad"
isProcessRunning = TRUE
Else
'do nothing as you only want to detect the current user running it
isProcessRunning = FALSE
End If
'else
'we didn't get any owner information - maybe not permitted by current user to ask for it
'Wscript.Echo "Could not get owner info for process [" & objProcess.Name & "]" & VBNewLine & "Error: " & Return
End If
Next
ELSE
'msgbox "We have NO instance of Notepad - Username is Irrelevant"
isProcessRunning = FALSE
END If
End Function
Related
I am trying to create a VBScript that kills 3 processes if they exist.
cscript.exe wscript.exe and cmd.exe
It needs to run a kill command and then check if the process still exists to verify that the previous command worked before continuing. I added a sleep command to give the script time to work before re-checking.
I need this in case I make another VBScript that loops a command that ends up getting stuck infinitely. I plan to link this script to a hotkey as a lifesaver should that happen.
How can I add more processes to this?
' TK CSCRIPT & WSCRIPT & CMD
Set objWMIService = GetObject ("winmgmts:")
foundProc = False
procName1 = "cscript.exe"
For Each Process in objWMIService.InstancesOf ("Win32_Process")
If StrComp(Process.Name,procName1,vbTextCompare) = 0 then
foundProc = True
procID = Process.ProcessId
End If
Next
If foundProc = True Then
Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process where ProcessId =" & procID)
For Each objProcess in colProcessList
objProcess.Terminate()
Next
WScript.Sleep(1000) 'wait 1 second before checking if the process still exists
Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process where ProcessId =" & procID)
If colProcessList.count = 0 Then
End If
End If
You can store what process did you want to kill into an Array like this code below :
Option Explicit
Dim Ws,fso,MyArray,LogFile,OutPut,count,MyProcess
Set Ws = CreateObject("Wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
MyArray = Array("cscript.exe","cmd.exe","wscript.exe","notepad.exe","mshta.exe")
LogFile = Left(Wscript.ScriptFullName,InstrRev(Wscript.ScriptFullName, ".")) & "log"
count = 0
If fso.FileExists(LogFile) Then fso.DeleteFile LogFile
Set OutPut = fso.OpenTextFile(LogFile,8,True)
For Each MyProcess in MyArray
Call Kill(MyProcess)
Next
OutPut.WriteLine String(50,"=")
OutPut.WriteLine count & " Process were killed !"
OutPut.WriteLine String(50,"=")
If fso.FileExists(LogFile) Then
ws.run LogFile 'To show the LogFile
End if
'---------------------------------------------------------------------------------------------------
Sub Kill(MyProcess)
On Error Resume Next
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)
If Err <> 0 Then
OutPut.WriteLine Err.Description
End If
Next
End Sub
'---------------------------------------------------------------------------------------------------
I was able to piggyback off of Hackoo's response so a big thank you to him for helping me get in the right direction.
Option Explicit
Dim fso,myArray,procName,ws
Set ws = CreateObject("Wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
myArray = Array("cmd.exe","cscript.exe","wscript.exe")
For Each procName in myArray
Call Kill(procName)
Next
'---------------------------------------------------------------------------------------------------
Sub Kill(procName)
Dim colProcess,name,objWMIService,strComputer
strComputer = "."
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcess = objWMIService.ExecQuery ("Select * from Win32_Process Where Name like '" & procName & "'")
For Each name in colProcess
name.Terminate
Next
End Sub
'---------------------------------------------------------------------------------------------------
Looking to see if there would be a way for users to update their MS Access db front end by clicking a button. The button would then trigger a batch file that would grab the file from a location on our server, and overwrite the current db on the users local PC. All done within one office, so network addresses would be all the same.
Location of file to copy: 10.0.0.0.5/Data/DB/Database.accdb
Location of file to overwrite: c:\DB\Database.accdb
Any ideas? Ideally I would love for someone to write a nice exe file that deletes the older version and installs the newer version, but can't write that kind of code.
Write a batch file to retrieve the newer version of the front end from it's source and copy it into the folder where the user's copy of the front end file lives. Add a line at the end of the batch file to launch msacess.exe with the filename of your front end program as a command line parameter.
The batch file can be located anywhere, but I recommend locating it in the folder where your application front end will reside.
Create a Windows shortcut to the batch file, which can be placed on the users' Desktop or anywhere else the user expects to launch the application.
Bonus points for dressing up the shortcut to the batch file by changing the icon: Right-click|Properties|Change icon... button.
A nice article on the topic can be found here:
Deploy and update a Microsoft Access application in a Citrix environment
It uses neither a bat, nor an exe, but a VBscript:
Option Explicit
' Launch script for PPT test/development/operation.
' Version 1.3.0
' 2013-09-15
' Cactus Data. Gustav Brock
Const DESKTOP = &H10
Const LOCALAPPDATA = &H1C
Dim objFSO
Dim objAppShell
Dim objDesktopFolder
Dim objLocalAppDataFolder
Dim objLocalFolder
Dim objRemoteFolder
Dim strLocalFolder
Dim strRemoteFolder
Dim strDesktopFolder
Dim strLocalAppDataFolder
Dim strLocalAppDataDsgFolder
Dim strLocalAppDataDsgPptFolder
Dim strDsgSubfolder
Dim strPptSubfolder
Dim strPptAppSubfolder
Dim strPptNcSuffix
Dim strAppName
Dim strAppSuffix
Dim strShortcutName
Dim strAppLocalPath
Dim strAppLocalBackPath
Dim strAppRemotePath
Dim strShortcutLocalPath
Dim strShortcutRemotePath
Dim strRegPath
Dim strRegKey
Dim strRegValue
Dim booNoColour
Dim varValue
' Adjustable parameters.
strDsgSubfolder = "DSG"
strPptSubfolder = "PPT"
strPPtNcSuffix = "NC"
' ---------------------------------------------------------------------------------
' Uncomment one folder name only:
'strPptAppSubfolder = "Development"
strPptAppSubfolder = "Operations"
'strPptAppSubfolder = "Test"
' ---------------------------------
' Indicate if the script is for the normal version (0) or the no-colour version (1):
booNoColour = 0
' ---------------------------------------------------------------------------------
strRemoteFolder = "K:\_Shared\Sales Planning\Environments\" & strPptAppSubfolder
If booNoColour = 1 Then
strAppSuffix = strPptNcSuffix
Else
strAppSuffix = ""
End If
strAppName = "SalesPlanningTool" & strAppSuffix & ".accdb"
If strPptAppSubfolder = "Operations" Then
If strAppSuffix = "" Then
strShortcutName = "RunPPT.lnk"
Else
strShortcutName = "RunPPT " & strAppSuffix & ".lnk"
End If
Else
If strAppSuffix = "" Then
strShortcutName = "RunPPT " & strPptAppSubfolder & ".lnk"
Else
strShortcutName = "RunPPT " & strAppSuffix & " " & strPptAppSubfolder & ".lnk"
End If
End If
' Enable simple error handling.
On Error Resume Next
' Find user's Desktop and AppData\Local folder.
Set objAppShell = CreateObject("Shell.Application")
Set objDesktopFolder = objAppShell.Namespace(DESKTOP)
strDesktopFolder = objDesktopFolder.Self.Path
Set objLocalAppDataFolder = objAppShell.Namespace(LOCALAPPDATA)
strLocalAppDataFolder = objLocalAppDataFolder.Self.Path
' Dynamic parameters.
strLocalAppDataDsgFolder = strLocalAppDataFolder & "\" & strDsgSubfolder
strLocalAppDataDsgPptFolder = strLocalAppDataDsgFolder & "\" & strPptSubfolder
strLocalFolder = strLocalAppDataDsgPptFolder & "\" & strPptAppSubfolder
strAppLocalPath = strLocalFolder & "\" & strAppName
strShortcutLocalPath = strDesktopFolder & "\" & strShortcutName
' Permanent parameters.
strAppRemotePath = strRemoteFolder & "\" & strAppName
strShortcutRemotePath = strRemoteFolder & "\" & strShortcutName
' Create the File System Object.
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(strRemoteFolder) Then
Call ErrorHandler("No access to " & strRemoteFolder & ".")
Else
Set objRemoteFolder = objFSO.GetFolder(strRemoteFolder)
' If local folder does not exist, create the folder.
If Not objFSO.FolderExists(strLocalFolder) Then
If Not objFSO.FolderExists(strLocalAppDataDsgFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalAppDataDsgFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalAppDataDsgFolder & " could not be created.")
End If
End If
If Not objFSO.FolderExists(strLocalAppDataDsgPPtFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalAppDataDsgPptFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalAppDataDsgPptFolder & " could not be created.")
End If
End If
If Not objFSO.FolderExists(strLocalFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalFolder & " could not be created.")
End If
End If
End If
Set objLocalFolder = objFSO.GetFolder(strLocalFolder)
End If
If Not objFSO.FileExists(strAppRemotePath) Then
Call ErrorHandler("The application file:" & vbCrLf & strAppRemotePath & vbCrLF & "could not be found.")
Else
' Close a running PPT.
Call KillTask("PPT")
' Wait while TaskKill is running twice to close the instance(s) of PPT and PPT Background.
Call AwaitProcess("taskkill.exe")
Call KillTask("PPT Background")
' Wait while TaskKill is running twice to close the instance(s) of PPT and PPT Background.
Call AwaitProcess("taskkill.exe")
' Copy app to local folder.
If objFSO.FileExists(strAppLocalPath) Then
objFSO.DeleteFile(strAppLocalPath)
If Not Err.Number = 0 Then
Call ErrorHandler("The application file:" & vbCrLf & strAppName & vbCrLF & "can not be refreshed/updated. It may be in use.")
End If
End If
If objFSO.FileExists(strAppLocalPath) Then
Call ErrorHandler("The local application file:" & vbCrLf & strAppLocalPath & vbCrLF & "could not be replaced.")
Else
objFSO.CopyFile strAppRemotePath, strAppLocalPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Application could not be copied to " & strLocalFolder & ".")
End If
' Create copy for PPT Background.
strAppLocalBackPath = Replace(Replace(strAppLocalPath, ".accdb", ".accbg"), "SalesPlanningTool", "SalesPlanningToolBack")
objFSO.CopyFile strAppLocalPath, strAppLocalBackPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Background application could not be copied to " & strLocalFolder & ".")
End If
End If
' Copy shortcut.
objFSO.CopyFile strShortcutRemotePath, strShortcutLocalPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Shortcut could not be copied to your Desktop.")
End If
End If
' Write Registry entries for Access security.
strRegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Access\Security\"
strRegValue = "VBAWarnings"
strRegPath = strRegKey & strRegValue
varValue = 1
Call WriteRegistry(strRegPath, varValue,"REG_DWORD")
strRegKey = strRegKey & "Trusted Locations\LocationLocalAppData\"
strRegValue = "AllowSubfolders"
strRegPath = strRegKey & strRegValue
varValue = 1
Call WriteRegistry(strRegPath, varValue, "REG_DWORD")
strRegValue = "Date"
strRegPath = strRegKey & strRegValue
varValue = Now
varValue = FormatDateTime(varValue, vbShortDate) & " " & FormatDateTime(varValue, vbShortTime)
Call WriteRegistry(strRegPath, varValue, "REG_SZ")
strRegValue = "Description"
strRegPath = strRegKey & strRegValue
varValue = "Local AppData"
Call WriteRegistry(strRegPath, varValue, "REG_SZ")
strRegValue = "Path"
strRegPath = strRegKey & strRegValue
varValue = strLocalAppDataFolder & "\"
Call WriteRegistry(strRegPath, varValue, "REG_SZ")
' Run PPT.
If objFSO.FileExists(strAppLocalPath) Then
Call RunApp(strAppLocalPath, False)
Else
Call ErrorHandler("The local application file:" & vbCrLf & strAppLocalPath & vbCrLF & "could not be found.")
End If
Set objRemoteFolder = Nothing
Set objLocalFolder = Nothing
Set objLocalAppDataFolder = Nothing
Set objDesktopFolder = Nothing
Set objAppShell = Nothing
Set objFSO = Nothing
WScript.Quit
' Supporting subfunctions
' -----------------------
Sub RunApp(ByVal strFile, ByVal booBackground)
Dim objShell
Dim intWindowStyle
' Open as default foreground application.
intWindowStyle = 1
Set objShell = CreateObject("WScript.Shell")
objShell.Run Chr(34) & strFile & Chr(34), intWindowStyle, False
Set objShell = Nothing
End Sub
Sub KillTask(ByVal strWindowTitle)
Dim objShell
Set objShell = CreateObject("WScript.Shell")
objShell.Run "TaskKill.exe /FI ""WINDOWTITLE eq " & strWindowTitle & """", 7, False
Set objShell = Nothing
End Sub
Sub AwaitProcess(ByVal strProcess)
Dim objSvc
Dim strQuery
Dim colProcess
Dim intCount
Set objSvc = GetObject("winmgmts:root\cimv2")
strQuery = "select * from win32_process where name='" & strProcess & "'"
Do
Set colProcess = objSvc.Execquery(strQuery)
intCount = colProcess.Count
If intCount > 0 Then
WScript.Sleep 300
End If
Loop Until intCount = 0
Set colProcess = Nothing
Set objSvc = Nothing
End Sub
Sub WriteRegistry(ByVal strRegPath, ByVal varValue, ByVal strRegType)
' strRegType should be:
' "REG_SZ" for a string
' "REG_DWORD" for an integer
' "REG_BINARY" for a binary or boolean
' "REG_EXPAND_SZ" for an expandable string
Dim objShell
Set objShell = CreateObject("WScript.Shell")
Call objShell.RegWrite(strRegPath, varValue, strRegType)
Set objShell = Nothing
End Sub
Sub ErrorHandler(Byval strMessage)
Set objRemoteFolder = Nothing
Set objLocalFolder = Nothing
Set objLocalAppDataFolder = Nothing
Set objDesktopFolder = Nothing
Set objAppShell = Nothing
Set objFSO = Nothing
WScript.Echo strMessage
WScript.Quit
End Sub
You could probably convert it to PowerShell, which I would use today.
I use a vbscript for that purpose. I only update the path for the file due to be copied and then I sent an email to the users with a link to the script. The user clicks the link and the script is executed.
Copy the code below to a text file and save it as .vbs. Don't forget to set the path for the file due to be copied.
Option Explicit
Call Main()
Private Sub Main()
const folderFrom = "\\Somepath\Somefolder\" 'Folder: Must supply backslash
const fileName = "SomeFile.accdb" 'File name with extension
const overwrite = -1 'OverWrite = True
'Ask user to proceed
dim msg
msg = "The script will copy the file below to your desktop. " & vbNewLine & vbNewLine & _
String(75,"_") & vbNewLine & vbNewLine & _
"File: " & " " & " " & " " & " " & " " & " " & " '" & fileName & "' " & vbNewLine & _
"Folder: " & " " & " '" & folderFrom & "' " & vbNewLine & _
String(75,"_") & vbNewLine & vbNewLine & _
"Proceed?"
if MsgBox(msg, vbYesNo + vbQuestion, "FileCopy Confirmation") = vbNo then exit sub
on error resume next
dim filesys
set filesys = CreateObject("Scripting.FileSystemObject")
'File exists in folder?
if not filesys.FileExists(folderFrom & fileName) then
MsgBox "File not found. Task aborted. ", vbOKOnly + vbExclamation, "Attention:"
exit sub
end if
'User's desktop path
dim desktopPath
desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
'Copy file
filesys.CopyFile folderFrom & fileName, desktopPath & fileName, overwrite
'Validate file copied
if filesys.FileExists(desktopPath & fileName) then
Msgbox "File copied successfully.", vbOKOnly + vbInformation, "Success!"
else
MsgBox "File could not be copied... ", vbOKOnly + vbExclamation, "Copy Failed..."
end if
End Sub
Suggestion:
You shouldn't overwrite the existing front-end database but instead you should consider versioning e.g. v2.0, v2.1, v2.2 etc. for better tracking.
We have a VBScript that downloads chunks of data from an SAP Business Object database into so-called slices, which are basically .csv files. The script worked perfectly so far, I haven't really had to look into it at all. But the failure now is this:
The script file section this error refers to is the dbConn.Execute(strSQL) line in the below code (5th from below).
What I tried so far, was to add these commands but they don't seem to solve anything:
'dbConn.ConnectionTimeout = 100
'dbConn.CommandTimeout = 100
The script itself (not all of it, I'm not sure the rest is needed):
Sub subRunFilesInFolder(strFolder)
Dim FSO, objFolder, objFiles
Dim i, intTS, intTS_file_start, ts, tsKillBefore, TS_file_start, strModelName
Dim dbConn, RST, RST2, strSQL
Dim strVBSmodel
Dim blRunIt
'INIs
strModelName = "bo_vbs_runner_1.5 "
strConn = "DRIVER={SQL Server};SERVER=EUBASEURCIREP01;UID=ser_login;PWD=ser_login;DATABASE=ser"
strComputer = FunstrComputerName
strBORunner = "\\Eubaseurcirep01\reporting\DEVELOPMENT\BO\Automation\Models\BO_auto_run.xlsb"
'Sets
Set dbConn = CreateObject("ADODB.Connection")
Set RST = CreateObject("ADODB.RecordSet")
Set RST2 = CreateObject("ADODB.RecordSet")
Set WshShell = WScript.CreateObject("WScript.Shell")
Set FSO = Wscript.CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder(strFolder)
Set objFiles = objFolder.Files
Set appExcel = CreateObject("Excel.Application")
'dbConn.ConnectionTimeout = 100
'dbConn.CommandTimeout = 100
strVBSmodel = strModelName & strComputer & " " & FunstrUserName & " " & funCurrProcessId & " " & FunGetProcessIDCurrentOfExcel(strComputer)
appExcel.Application.Visible = False
appExcel.Displayalerts = False
Set objBORunner = appExcel.Workbooks.Open(strBORunner)
dbConn.Open strConn
ts = FunGetServerNow(dbConn,RST)
tsKillBefore = DateAdd("N", -15, ts)
intTS = funTimeStampToInteger(FunGetServerNow(dbConn, RST))
'Get ReportDate
strSQL = "SELECT yyyymmdd FROM map.reportdate WHERE dtAct=cast(GETDATE() as DATE);"
RST.Open strSQL, dbConn
If RST.EOF Then
strReportDate="99991231"
Else
strReportDate=RST.fields(0).value
End If
RST.close
'Kill stucked excel and vbs processes
strSQL = "SELECT distinct * FROM [ser].[bo].[_log] WHERE [proc]='BO VBS' AND result_text='started' AND end_timestamp<" & funTimeStampToInteger(tsKillBefore) & _
" AND lower(model) like '% " & LCase(strComputer) & " %';"
RST.Open strSQL,dbConn
If RST.EOF Then 'Nothing to kill
Else
Do While Not RST.EOF
strOldVBS = split(RST.fields("model"), " ")(3)
strOldExcel = split(RST.fields("model"), " ")(4)
Call SubKillProcessIDOnstrComputer(strComputer, strOldVBS)
Call SubKillProcessIDOnstrComputer(strComputer, strOldExcel)
strSQL = "UPDATE [ser].[bo].[_log] SET result_text='stopped', end_timestamp='" & funTimeStampToInteger(FunGetServerNow(dbConn,RST2)) & "' " & _
"WHERE [proc]='BO VBS' AND result_text='started' AND model='" & RST.fields("model").value & "' AND parameters='" & _
RST.fields("parameters").value & "';"
dbConn.Execute(strSQL)
RST.MoveNext
Loop
End If
RST.close
To Decode 0x8004nnnn Errors
HResults with facility code 4 means the HResult contains OLE errors (0x0 =
to 0x1ff) while the rest of the range (0x200 onwards) is component =
specific errors so 20e from one component will have a different meaning =
to 20e from another component.
You are lucky as your component is telling you it's OLDB with it's error - TIMEOUT
In Windows 7, I've got a VBScript that creates an email in Outlook with a link to the file when you right-click in Windows Explorer. The script is run by creating a shortcut to it and adding it to %userprofile%\SendTo (which shows up in the Send to when you right-click the file). The goal is to be able to send a link to the file and the folder that contains it, rather than sending it as an attachment. It works fine except it always give a link directly to the file. How do I modify it so it also provides a link to the folder in the second line?
Const olMailItem = 0
Const olFolderInbox = 6
If WScript.Arguments.Count = 0 Then
WScript.Quit
End If
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set colItems = objWMIService.ExecQuery _
("Select * From Win32_Process Where Name = 'outlook.exe'")
If colItems.Count = 0 Then
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
objFolder.Display
End If
strFile = WScript.Arguments.Item(0)
Set objOutlook = CreateObject("Outlook.Application")
Set objItem = objOutlook.CreateItem(olMailItem)
objItem.Subject = "Here is a link to a file..."
objItem.HTMLBody = "Link to the file: " & strFile & "<BR>Link to the folder: " & strFile & ""
objItem.Display
Might be a simple answer, but I haven't been able to figure it out. Any help would be appreciated!
The FileSystemObject object and it's GetParentFolderName method could help. Note that for any of methods used (in next script) hold: a method works only on the provided path string. It does not attempt to resolve the path, nor does it check for the existence of the specified path.
option explicit
Dim strFile, FSO, oFile
If WScript.Arguments.Count > 0 Then
strFile = WScript.Arguments.Item(0)
Else
strFile = "D:\Remote\bat\COCL\bu bu bu\somefile.ext"
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Wscript.Echo "FSO 'path' methods" & vbNewLine & "---------------------" _
& vbNewLine & "GetAbsolutePathName: " & FSO.GetAbsolutePathName( strFile) _
& vbNewLine & "GetParentFolderName: " & FSO.GetParentFolderName( strFile) _
& vbNewLine & "GetDriveName: " & FSO.GetDriveName( strFile) _
& vbNewLine & "GetBaseName: " & FSO.GetBaseName( strFile) _
& vbNewLine & "GetExtensionName: " & FSO.GetExtensionName( strFile) _
& vbNewLine & "GetFileName: " & FSO.GetFileName( strFile)
Set FSO = Nothing
Wscript.Quit
Ok my problem here is that I'm getting a Variable is undefined: 'objObject' error at line 39 char 4. All is good if I remove lines 39-46 but the purpose of the code is to reformat the output from echoing the object which looks like this z:\\\\BAIBOA\\test.txt and change it into a string that looks like this z:\BAIBOA\test.txt to be used later in the code. This code has been edited from another source so maybe I'm not fully understanding what's going on. Any help would be greatly appreciated.
Option Explicit
Dim arrFolders, strComputer, objWMIService, strFolder, strCommand
Dim i, strQuery, strNewFile, arrNewFile, strFilePath, strTempFilePath
Dim colMonitoredEvents, strQueryFolder
arrFolders = Array("Z:\\\\test1", "Z:\\\\test2", "Z:\\\\test2")
strComputer = "."
'strQueryFolder = Replace(strFolder, "\", "\\\\")
Set objWMIService = GetObject("winmgmts:\\" & strComputer _
& "\root\CIMV2")
'Loop through the array of folders setting up the monitor for Each
i = 0
For Each strFolder In arrFolders
'Create the event sink
strCommand = "Set EventSink" & i & " = WScript.CreateObject" & _
"(""WbemScripting.SWbemSink"", ""SINK" & i & "_"")"
ExecuteGlobal strCommand
'Setup Notification
strQuery = "SELECT * FROM __InstanceCreationEvent WITHIN 10 " & _
"WHERE Targetinstance ISA 'CIM_DirectoryContainsFile'" & _
" and TargetInstance.GroupComponent = " & _
"'Win32_Directory.Name=""" & strFolder & """'"
strCommand = "objWMIservice.ExecNotificationQueryAsync EventSink" & _
i & ", strQuery"
ExecuteGlobal strCommand
'Create the OnObjectReady Sub
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & _
"objAsyncContext)" & VbCrLf & vbTab & _
"Wscript.Echo objObject.TargetInstance.PartComponent" & _
VbCrLf & "End Sub"
'WScript.Echo strCommand
ExecuteGlobal strCommand
i = i + 1
---> Line 39 Set objLatestEvent = objObject.TargetInstance.PartComponent
strNewFile = objLatestEvent.TargetInstance.PartComponent
arrNewFile = Split(strNewFile, "=")
strFilePath = arrNewFile(1)
strFilePath = Replace(strFilePath, "\\", "\")
strFilePath = Replace(strFilePath, Chr(34), "")
strFileName = Replace(strFilePath, strFolder, "")
'strTempFilePath = WScript.CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "\TEMP.M4A"
Wscript.Echo strFilePath
Next
WScript.Echo "Waiting for events..."
i = 0
While (True)
Wscript.Sleep(1000)
Wend
Ok Ive came up with a solution for the output but now im stuck getting the script to increment correctly and will only goto the next folder if the first folder gets a file. What i need is for it to scan the array for new files not 1 by 1. :( any suggestions
Option Explicit
Dim arrFolders, strComputer, objWMIService, strFolder, strCommand
Dim i, strQuery, strNewFile, arrNewFile, strFilePath, strTempFilePath
Dim colMonitoredEvents, strQueryFolder, objObject, objLatestEvent
Dim strFileName
arrFolders = Array("Z:\\\\test1", "Z:\\\\test2", "Z:\\\\test2")
strComputer = "."
i = 0
For Each strFolder In arrFolders
'trQueryFolder = Replace(strFolder, "\", "\\\\")
strQueryFolder = strFolder
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery ("SELECT * FROM __InstanceCreationEvent WITHIN 10 " & " WHERE Targetinstance ISA 'CIM_DirectoryContainsFile' and TargetInstance.GroupComponent='Win32_Directory.Name=""" & strQueryFolder & """'")
Wscript.Echo strQueryFolder
'Do
Set objLatestEvent = colMonitoredEvents.NextEvent
strNewFile = objLatestEvent.TargetInstance.PartComponent
arrNewFile = Split(strNewFile, "=")
strFilePath = arrNewFile(1)
strFilePath = Replace(strFilePath, "\\", "\")
strFilePath = Replace(strFilePath, Chr(34), "")
strFileName = Replace(strFilePath, strFolder, "")
strTempFilePath = WScript.CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "\TEMP.M4A"
' DO THE OPERATION STUFF
' ...
'Wscript.Echo objLatestEvent.TargetInstance.PartComponent
Wscript.Echo strFilePath
' If strFileName = strQueryFolder then i = i + 1 Else
'Loop
i = i + 1
Next
'WScript.Echo "Waiting for events..."
i = 0
While (True)
Wscript.Sleep(1000)
Wend