Private Const INFINITE = -1&
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
...
Dim FileName As String
Dim params As String
FileName = "C:\program.exe"
params = "some params here"
Dim pid As Long
Dim lngProcess As Long
pid = Shell(Chr(34) & FileName & Chr(34) & " " & params, vbNormalFocus)
lngProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, CLng(pid))
If lngProcess <> 0 Then
WaitForInputIdle lngProcess, INFINITE
TerminateProcess lngProcess, 0&
End If
'code for Form1
Private Sub cmdCheck_Click()
'check if application is running
If IsTaskRunning(sAppName) Then
MsgBox "Application '" & sAppName & "' is running!"
Else
MsgBox "Application '" & sAppName & "' is not running!"
End If
End Sub
Private Sub cmdClose_Click()
'close application
Call EndTask(sAppName)
End Sub
Private Sub cmdStart_Click()
'start an application
Shell sAppPath, vbNormalFocus
End Sub
Private Sub Form_Load()
sAppName = "Microsoft Access"
sAppPath = "C:\Program Files\access97\Office\MSACCESS.EXE"
End Sub
'Code for Module1
Option Explicit
'API's Function Declarations
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
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
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As String) As Long
'API Constants
Public Const GWL_STYLE = -16
Public Const WS_DISABLED = &H8000000
Public Const WM_CANCELMODE = &H1F
Public Const WM_CLOSE = &H10
Public sAppName As String, sAppPath As String
Public Function IsTaskRunning(sWindowName As String) As Boolean
Dim hwnd As Long, hWndOffline As Long
On Error GoTo IsTaskRunning_Eh
'get handle of the application
'if handle is 0 the application is currently not running
hwnd = FindWindow(0&, sWindowName)
If hwnd = 0 Then
IsTaskRunning = False
Exit Function
Else
IsTaskRunning = True
End If
IsTaskRunning_Exit:
Exit Function
IsTaskRunning_Eh:
Call ShowError(sWindowName, "IsTaskRunning")
End Function
Public Function EndTask(sWindowName As String) As Integer
Dim X As Long, ReturnVal As Long, TargetHwnd As Long
'find handle of the application
TargetHwnd = FindWindow(0&, sWindowName)
If TargetHwnd = 0 Then Exit Function
If IsWindow(TargetHwnd) = False Then
GoTo EndTaskFail
Else
'close application
If Not (GetWindowLong(TargetHwnd, GWL_STYLE) And WS_DISABLED) Then
X = PostMessage(TargetHwnd, WM_CLOSE, 0, 0&)
DoEvents
End If
End If
GoTo EndTaskSucceed
EndTaskFail:
ReturnVal = False
MsgBox "EndTask: cannot terminate " & sWindowName & " task"
GoTo EndTaskEndSub
EndTaskSucceed:
ReturnVal = True
EndTaskEndSub:
EndTask% = ReturnVal
End Function
Public Function ShowError(sText As String, sProcName As String) 'this function displays an error that occurred
Dim sMsg As String
sMsg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & vbCrLf & Err.Description
MsgBox sMsg, vbCritical, sText & Space(1) & sProcName
Exit Function
End Function
In the general case though, if you can get a 'not ready' returned, then that's pretty good.
You could spin lock
While Not Ready
Wend
I'd at least shorten the wait time to a half second or so. Three seconds is so long (in the computer world)