|
Psycho
|
I wrote this class module some years ago. It's a bit long, and may do more than you want. Hopefully it will help or at least give you some idea on how to do it yourself.
Option Explicit
'Properties
'-----------
' ShowWindow as integer (write-only)
' SW_HIDE = 0
' SW_SHOWNORMAL = 1
' SW_NORMAL = 1
' SW_SHOWMINIMIZED = 2
' SW_SHOWMAXIMIZED = 3
' SW_MAXIMIZE = 3
' SW_SHOWNOACTIVATE = 4
' SW_SHOW = 5
' SW_MINIMIZE = 6
' SW_SHOWMINNOACTIVE = 7
' SW_SHOWNA = 8
' SW_RESTORE = 9
' SW_SHOWDEFAULT = 10
' SW_MAX = 10
' LastError as string (read-only) Last error message
' LastErrorNumber as integer (read-only) Last error number
'
'Methods
'-----------
' RunAndWaitForTerminate
' (Process As String)
' As Boolean
' Executes the specified process and waits for it to terminate.
' Returns true if successful, else sets LastError and LastErrorNumber.
'
' RunAndGetProccessId
' (Process as String, ProcessID as Long, ProcessHandle as Long)
' As Boolean
' Input: Process
' Ouput: ProcessID, ProcessHandle
' Executes the specified process and returns it's process id and handle
' Returns true if successful, else sets LastError and LastErrorNumber.
'
' CheckStillRunning
' (ProcessHandle as Long, StillRunning as Boolean)
' As Boolean
' Input: ProcessId
' Ouput: StillRunning
' StillRunning returns True if still running, returns False and closes handle
' if not running.
' Returns true if successful, else sets LastError and LastErrorNumber.
'
' CloseWindow
' (WindowHandle as Long)
' as Boolean
' Input: WindowHandle
' Returns true if successful, else sets LastError and LastErrorNumber.
'
' GetWindowHandleForProcessId
' (ProcessId as Long, WindowHandle as Long, Optional WindowTitle as String)
' as Boolean
' Input: ProcessId
' Ouput: WindowHandle, WindowTitle (optional)
' Returns true if successful, else sets LastError and LastErrorNumber.
'
' GetWindowHandleByTitle
' (WindowTitle as String, WindowHandle as Long, Optional MatchExact as Boolean)
' as Boolean
' Input: WindowTitle
' MatchExact - Only return window with exact match on WindowTitle,
' otherwise use sub-string match.
' Output: WindowHandle
' Returns true if successful, else sets LastError and LastErrorNumber.
' Note: Returns the 1st window that matches the WindowTitle.
'
' GetShortFileName
' (sLongFileName As String, sShortFileName As String)
' As Boolean
' Input: sLongFileName
' Output: sShortFileName
' Returns true if successful, else sets LastError and LastErrorNumber.
'
' SplitFileNameAndParams
' (sFilePathNameParams As String, sFilePathName As String, sParams As String)
' Input: sFilePathNameParams
' Output: sFilePathName
' sParams
'
Private sLastError As String
Private lLastError As Long
'API stuff
Public Enum ShowWindow
SW_HIDE = 0
SW_SHOWNORMAL = 1
SW_NORMAL = 1
SW_SHOWMINIMIZED = 2
SW_SHOWMAXIMIZED = 3
SW_MAXIMIZE = 3
SW_SHOWNOACTIVATE = 4
SW_SHOW = 5
SW_MINIMIZE = 6
SW_SHOWMINNOACTIVE = 7
SW_SHOWNA = 8
SW_RESTORE = 9
SW_SHOWDEFAULT = 10
SW_MAX = 10
End Enum
Private Const STARTF_USESHOWWINDOW = &H1
Private Const SYNCHRONIZE = &H100000
Private Const INFINITE = &HFFFF ' Infinite timeout
Private Const CREATE_SUSPENDED = &H4
Private Const DETACHED_PROCESS = &H8
Private Const CREATE_NEW_CONSOLE = &H10
Private Const NORMAL_PRIORITY_CLASS = &H20
Private Const IDLE_PRIORITY_CLASS = &H40
Private Const HIGH_PRIORITY_CLASS = &H80
Private Const REALTIME_PRIORITY_CLASS = &H100
Private Const CREATE_NEW_PROCESS_GROUP = &H200
Private Const CREATE_NO_WINDOW = &H8000000
Private Const WAIT_FAILED = -1&
Private Const WAIT_OBJECT_0 = 0
Private Const WAIT_ABANDONED = &H80&
Private Const WAIT_ABANDONED_0 = &H80&
Private Const WAIT_TIMEOUT = &H102&
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private myStartupInfo As STARTUPINFO
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessBynum Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDirectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Const GW_CHILD = 5
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDLAST = 1
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDPREV = 3
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_CLOSE = &H10
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
(ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
'FileSystemObject (scrrun.dll)
Private fso As New Scripting.FileSystemObject
Property Get LastError() As String
LastError = sLastError
End Property
Property Get LastErrorNumber() As Long
LastErrorNumber = lLastError
End Property
Property Let ShowWindow(ShowWindow As Integer)
myStartupInfo.wShowWindow = ShowWindow
End Property
Public Function RunAndGetProcessId(Process As String, ProcessId As Long, ProcessHandle As Long) As Boolean
Dim lRtnCode As Long
Dim myProcessInfo As PROCESS_INFORMATION
Dim sPathAndName As String
Dim sParams As String
Dim sTemp As String
sLastError = ""
lLastError = 0
On Error GoTo RunAndGetProcessIdError
SplitFileNameAndParams Process, sPathAndName, sParams
If sParams = "" Then sParams = vbNullString
'Make sure the process file path and name are specified as short names (8.3, no spaces)
sTemp = sPathAndName
GetShortFileName sTemp, sPathAndName
'Confirm process exists
If Dir(sPathAndName) = "" Then
'Try again with .exe added
If Dir(sPathAndName & ".exe") = "" Then
lLastError = vbObjectError + 500
sLastError = "File Not Found [" & sPathAndName & "]"
Exit Function
Else
sPathAndName = sPathAndName & ".exe"
End If
End If
lRtnCode = CreateProcessBynum(vbNullString, sPathAndName & " " & sParams, 0, 0, True, _
NORMAL_PRIORITY_CLASS, ByVal 0&, vbNullString, myStartupInfo, myProcessInfo)
If lRtnCode = 0 Then 'Failure
lLastError = GetLastError()
sLastError = "CreateProcessBynum Error; Process [" & Process & "], Short Filename Process [" & sPathAndName & " " & sParams & "]"
'Just in case, close the process handle
On Error Resume Next
Call CloseHandle(myProcessInfo.hThread)
Exit Function
End If
'We don't need the thread handle
Call CloseHandle(myProcessInfo.hThread)
'Return the processid and thread
ProcessHandle = myProcessInfo.hProcess
ProcessId = myProcessInfo.dwProcessId
RunAndGetProcessId = True
Exit Function
RunAndGetProcessIdError:
sLastError = Error$
lLastError = Err
End Function
Public Function CheckStillRunning(ProcessHandle As Long, StillRunning As Boolean) As Boolean
Dim lRtnCode As Long
sLastError = ""
lLastError = 0
On Error GoTo StillRunningError
'Check if running
lRtnCode = WaitForSingleObject(ProcessHandle, 0)
If lRtnCode <> WAIT_TIMEOUT Then
' No timeout, app is terminated
StillRunning = False
' Kill the last handle of the process
Call CloseHandle(ProcessHandle)
Else
StillRunning = True
End If
CheckStillRunning = True
Exit Function
StillRunningError:
sLastError = Error$
lLastError = Err
End Function
Public Function GetWindowHandleForProcessId(ProcessId As Long, WindowHandle As Long, _
Optional WindowTitle As String) As Boolean
Dim lHwnd As Long
Dim lThread As Long
Dim lProcessId As Long
Dim lTitleLen As Long
Dim sTitle As String
sLastError = ""
lLastError = 0
On Error GoTo GetWindowHandleForProcessIdError
'The desktop is the highest window
lHwnd = GetDesktopWindow()
'Its first child is the 1st top level window
lHwnd = GetWindow(lHwnd, GW_CHILD)
'Search through all the windows
Do While lHwnd <> 0
lThread = GetWindowThreadProcessId(lHwnd, lProcessId)
If lProcessId = ProcessId Then
'MsgBox "Handle:" & lHwnd & " Thread:" & lThread & " ProcessId" & lProcessId
WindowHandle = lHwnd
Exit Do
End If
'Get the next window
lHwnd = GetNextWindow(lHwnd, GW_HWNDNEXT)
Loop
'Did we find the window?
If lHwnd <> 0 Then
'Get the window title
If Not IsMissing(WindowTitle) Then
lTitleLen = GetWindowTextLength(lHwnd)
sTitle = String(lTitleLen + 1, " ")
lTitleLen = GetWindowText(lHwnd, sTitle, lTitleLen + 1)
WindowTitle = Left$(sTitle, lTitleLen)
End If
GetWindowHandleForProcessId = True
Else
sLastError = "No window handle found for ProcessId [" & ProcessId & "]"
lLastError = vbObjectError + 501
End If
Exit Function
GetWindowHandleForProcessIdError:
sLastError = Error$
lLastError = Err
End Function
Public Function CloseWindow(WindowHandle As Long) As Boolean
Dim lRtnCode As Long
sLastError = ""
lLastError = 0
On Error GoTo CloseWindowError
'Post a message to the process to close
lRtnCode = PostMessage(WindowHandle, WM_CLOSE, 0&, 0&)
If lRtnCode = 0 Then 'Failure
lLastError = GetLastError()
sLastError = "PostMessage Error; WindowHandle [" & WindowHandle & "]"
Exit Function
End If
CloseWindow = True
Exit Function
CloseWindowError:
sLastError = Error$
lLastError = Err
End Function
Public Function RunAndWaitForTerminate(Process As String) As Boolean
Dim lRtnCode As Long
Dim myProcessInfo As PROCESS_INFORMATION
Dim sPathAndName As String
Dim sParams As String
Dim sTemp As String
sLastError = ""
lLastError = 0
On Error GoTo RunAndWaitForTerminateError
SplitFileNameAndParams Process, sPathAndName, sParams
If sParams = "" Then sParams = vbNullString
'Make sure the process file path and name are specified as short names (8.3, no spaces)
sTemp = sPathAndName
GetShortFileName sTemp, sPathAndName
'Confirm process exists
If Dir(sPathAndName) = "" Then
'Try again with .exe added
If Dir(sPathAndName & ".exe") = "" Then
lLastError = vbObjectError + 500
sLastError = "File Not Found [" & sPathAndName & "]"
Exit Function
Else
sPathAndName = sPathAndName & ".exe"
End If
End If
lRtnCode = CreateProcessBynum(vbNullString, sPathAndName & " " & sParams, 0, 0, True, _
NORMAL_PRIORITY_CLASS, ByVal 0&, vbNullString, myStartupInfo, myProcessInfo)
If lRtnCode Then
If Not WaitForTerm(myProcessInfo) Then Exit Function
Else
lLastError = GetLastError()
sLastError = "CreateProcessBynum Error; Process [" & Process & "], Short Filename Process [" & sPathAndName & " " & sParams & "]"
'Just in case, close the process handle
On Error Resume Next
Call CloseHandle(myProcessInfo.hThread)
Exit Function
End If
RunAndWaitForTerminate = True
Exit Function
RunAndWaitForTerminateError:
sLastError = Error$
lLastError = Err
End Function
Public Function GetWindowHandleByTitle(WindowTitle As String, WindowHandle As Long, _
Optional MatchExact As Boolean, Optional FullWindowTitle As String) As Boolean
Dim lHwnd As Long
Dim lTitleLen As Long
Dim sTitle As String
WindowHandle = 0
sLastError = ""
lLastError = 0
On Error GoTo GetWindowHandleByTitleError
'The desktop is the highest window
lHwnd = GetDesktopWindow()
'Its first child is the 1st top level window
lHwnd = GetWindow(lHwnd, GW_CHILD)
'Search through all the windows
Do While lHwnd <> 0
lTitleLen = GetWindowTextLength(lHwnd)
sTitle = String(lTitleLen + 1, " ") 'Clear title buffer
lTitleLen = GetWindowText(lHwnd, sTitle, lTitleLen + 1)
sTitle = Left$(sTitle, lTitleLen)
If MatchExact Then
If LCase$(WindowTitle) = LCase$(sTitle) Then
WindowHandle = lHwnd
Exit Do
End If
Else
If InStr(LCase$(sTitle), LCase$(WindowTitle)) > 0 Then
WindowHandle = lHwnd
If Not IsMissing(FullWindowTitle) Then FullWindowTitle = sTitle
Exit Do
End If
End If
'Get the next window
lHwnd = GetNextWindow(lHwnd, GW_HWNDNEXT)
Loop
'Did we find the window?
If WindowHandle <> 0 Then
GetWindowHandleByTitle = True
Else
sLastError = "No window found for Window Title [" & WindowTitle & "]"
lLastError = vbObjectError + 502
End If
Exit Function
GetWindowHandleByTitleError:
sLastError = Error$
lLastError = Err
End Function
Private Function WaitForTerm(myProcessInfo As PROCESS_INFORMATION) As Boolean
Dim lRtnCode As Long
WaitForTerm = False
On Error GoTo WaitForTermError
'Let the process initialize (This is only necessary if we were going
'to perform interprocess communication).
Call WaitForInputIdle(myProcessInfo.hProcess, INFINITE)
'We don't need the thread handle
Call CloseHandle(myProcessInfo.hThread)
Do
lRtnCode = WaitForSingleObject(myProcessInfo.hProcess, 0)
If lRtnCode <> WAIT_TIMEOUT Then
' No timeout, app is terminated
Exit Do
End If
DoEvents
Loop While True
' Kill the last handle of the process
Call CloseHandle(myProcessInfo.hProcess)
WaitForTerm = True
Exit Function
WaitForTermError:
sLastError = Error$
lLastError = Err
End Function
Public Sub SplitFileNameAndParams(sFilePathNameParams As String, sFilePathName As String, sParams As String)
'The expected input is a run string which may contain
'command line parameters. This sub splits the File Path and Name from the Parameters
'Example;
'sFilePathNameParams= "c:\fund reporting\sungrd.bat 157 5/14/95"
'sFilePathName= "c:\fund reporting\sungrd.bat"
'sParams= "157 5/14/95"
Dim sTrimmedProcess As String
Dim nBackSlashIndex As Integer
Dim nSpaceIndex As Integer
Dim nSecondColenIndex As Integer
Dim nSecondDblBackslashIndex As Integer
Dim nSecondMarkerIndex As Integer
Dim nIndex As Integer
sTrimmedProcess = Trim$(sFilePathNameParams)
If Len(sTrimmedProcess) < 3 Then Exit Sub
'Note: The function will not work if the file name has spaces (My File Name.exe)
'This can be very tricky; The file path and name may start with a drive letter
'and colen ( c: ), or may start with two backslashes (\\computer\server\...).
'Also, one or more parameters may be included which are also files (path and name).
'We need to find the first space after the last backslash but prior to a second colon
'or double backslash.
'Examples:
'c:\Program Files\myprog.exe -R c:\data\file.dat
' ^
'c:\Program Files\myprog.exe -R \\comp1\data\file.dat
' ^
'\\comp1\Program Files\myprog.exe -R c:\data\file.dat
' ^
'\\comp1\Program Files\myprog.exe -R \\comp1\data\file.dat
' ^
'Find the second colon (if any)
nSecondColenIndex = InStr(3, sTrimmedProcess, ":")
'Find the second double backslash (if and)
nSecondDblBackslashIndex = InStr(3, sTrimmedProcess, "\\")
'It's possible that one parameter has a path with a colen and another
'parameter has a path with double backslashes. Keep the first one.
If nSecondColenIndex > 0 And nSecondDblBackslashIndex > 0 Then
If nSecondColenIndex < nSecondDblBackslashIndex Then
nSecondMarkerIndex = nSecondColenIndex
Else
nSecondMarkerIndex = nSecondDblBackslashIndex
End If
'Otherwise, the parameters only have the same path type (if any at all)
Else
If nSecondColenIndex > 0 Then
nSecondMarkerIndex = nSecondColenIndex
ElseIf nSecondDblBackslashIndex > 0 Then
nSecondMarkerIndex = nSecondDblBackslashIndex
Else
nSecondMarkerIndex = Len(sTrimmedProcess) + 1
End If
End If
If nSecondMarkerIndex = 3 Then Exit Sub
'Next find the last backslash prior to the second marker (colen or double backslash)
nIndex = 2
Do
nBackSlashIndex = nIndex
nIndex = InStr(nIndex + 1, sTrimmedProcess, "\")
Loop While nIndex > 0 And nIndex < nSecondMarkerIndex
'Now find the space between the file name and input parameters
nSpaceIndex = InStr(nBackSlashIndex + 1, sTrimmedProcess, " ")
If nSpaceIndex > 0 Then
sFilePathName = Left$(sTrimmedProcess, nSpaceIndex - 1)
sParams = Mid$(sTrimmedProcess, nSpaceIndex + 1)
Else
sFilePathName = sTrimmedProcess
sParams = ""
End If
End Sub
Public Function GetShortFileName(sLongFileName As String, sShortFileName As String) As Boolean
'Converts long path and file names into 8.3 format
Dim FileObject As Scripting.File
Dim sShortPath As String
Dim sLongPath As String
Dim nLen As Integer
Dim nIndex As Integer
Dim nBackSlashIndex As Integer
Dim bFileObjectError As Boolean
On Error GoTo ErrorTrap
'If any error occurs, we'll return a blank value
sShortFileName = ""
'Use the FileObject to get the short file name.
'Note: The FileObject can only be used if the file has an extension.
If InStr(sLongFileName, ".") > 0 Then
On Error Resume Next
Set FileObject = fso.GetFile(sLongFileName)
If Err.Number <> 0 Then
bFileObjectError = True
Else
sShortFileName = FileObject.ShortPath
If Err.Number <> 0 Then bFileObjectError = True
End If
'Close the FileObject
Set FileObject = Nothing
On Error GoTo ErrorTrap
End If
'If the file does not have a file extension, then we cannot use the
'FileObject to get it's short path and name. Instead,
'we'll use a Windows API call (but GetShortPathName can only
'return the short path name).
If InStr(sLongFileName, ".") = 0 Or bFileObjectError Then
'Unfortunatelly, the GetShortPathName function only works on paths without
'the filename. So we need to try and remove the file name.
'Find the last backslash.
Do
nBackSlashIndex = nIndex
nIndex = InStr(nIndex + 1, sLongFileName, "\")
Loop While nIndex > 0
If nBackSlashIndex = 0 Then Exit Function
sLongPath = Left$(sLongFileName, nBackSlashIndex)
sShortPath = String(255, " ")
nLen = GetShortPathName(sLongPath, sShortPath, Len(sShortPath))
sShortFileName = Left$(sShortPath, nLen) & Mid$(sLongFileName, nBackSlashIndex + 1)
End If
GetShortFileName = True
Exit Function
ErrorTrap:
sLastError = "GetShortFileName: " & Err.Description
lLastError = Err.Number
End Function
Private Sub Class_Initialize()
myStartupInfo.cb = Len(myStartupInfo)
myStartupInfo.dwFlags = STARTF_USESHOWWINDOW
myStartupInfo.wShowWindow = SW_SHOW
End Sub
Private Sub Class_Terminate()
Set fso = Nothing
End Sub
|