Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib _
"kernel32" (ByVal hprocess As Long, _
lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private Const STILL_ACTIVE = &H103
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Sub Command1_Click()
Dim ret&
ret = ShellAndWait("Notepad", vbNormalFocus)
MsgBox "Done"
End Sub
Function ShellAndWait(PathName As String, _
Optional WS As VbAppWinStyle = vbMinimizedFocus) As Double
' Drop-in replacement for VB's Shell command- except it
' doesn't return until shelled app is done. J.LeVasseur
' <lvass...@tiac.net> Pieced together from a couple of
' other people's ideas, actually. Works for me ...
'-------------------------------------------------------
Dim lhProcess As Long
Dim lExitcode As Long
Dim dProcessID As Double
'----------------------------
On Error GoTo errShellAndWait
dProcessID = Shell(PathName, WS)
lhProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, dProcessID)
Do
Call Sleep(50): DoEvents
Call GetExitCodeProcess(lhProcess, lExitcode)
Loop While (lExitcode = STILL_ACTIVE)
CloseHandle (lhProcess)
ShellAndWait = dProcessID
Exit Function
errShellAndWait:
If lhProcess <> 0 Then
CloseHandle (lhProcess)
End If
ShellAndWait = dProcessID
End FunctionPrivate Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Function IsProcessRunning(pid As Long) As Boolean
Dim hProcess As Long
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 0, pid)
CloseHandle hProcess
IsProcessRunning = hProcess
End Function
[blue]Option Explicit
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 Const NORMAL_PRIORITY_CLASS = &H20
Private Const INFINITE = &HFFFF
Private Const WAIT_OBJECT_0 = 0
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
Public Sub ExecCmd(ByVal cmdline As String)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ret As Long
Dim hProc As Long
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
' Start the shelled application:
hProc = CreateProcessA(vbNullString, cmdline, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)
If hProc <> 0& Then WaitForInputIdle hProc, INFINITE
' Wait for the shelled application to finish:
ret = -1 ' can't leave as default because that is same value as WAIT_OBJECT_0
Do Until ret = WAIT_OBJECT_0
ret = WaitForSingleObject(proc.hProcess, 10)
DoEvents
Loop
ret = CloseHandle(proc.hProcess)
End Sub[/blue][blue]Option Explicit
Private Sub Command1_Click()
ExecCmd "c:\windows\notepad.exe"
MsgBox "I only get here when launched program finishes" & vbCrLf & "thus this must be a ShellAndWait ..."
End Sub
Private Sub Form_Load()
Timer1.Interval = 1000
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
Text1.Text = FormatDateTime(Now, vbLongTime)
End Sub[/blue]Private Sub Command1_Click()
Dim hProcess As Long
hProcess = Shell("c:\windows\notepad.exe", vbNormalFocus)
Do While IsProcessRunning(hProcess)
DoEvents
Loop
MsgBox "I only get here when launched program finishes" & vbCrLf & "thus this must be a ShellAndWait ..."
End Sub[blue]
Private Sub Command1_Click()
Static ClickCount As Long
ClickCount = ClickCount + 1
ExecCmd "c:\windows\notepad.exe"
MsgBox "Click " & ClickCount & vbCrLf & "I only get here when launched program finishes" & vbCrLf & "thus this must be a ShellAndWait ..."
ClickCount = ClickCount - 1
End Sub[/blue]
