'这个问题以前讨论过,但是解决方案有一个小小的缺陷, 就是主程序不能刷新.Const SYNCHRONIZE = &H100000
Const INFINITE = &HFFFFFFFF
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
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 GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Sub Command1_Click()
Dim pId As Long, pHnd As Long
Const PROCESS_ALL_ACCESS = 0
pId = Shell("Notepad", vbNormalFocus) '现在用的是记事本
Do While IsActive(pId)
DoEvents
Loop
'调用的程序结束时,程序从下面一行继续运行
pHnd = OpenProcess(PROCESS_ALL_ACCESS, False, pId)
If pHnd <> 0 Then
Call WaitForSingleObject(pHnd, INFINITE)
Call CloseHandle(pHnd)
End If
Beep
End Sub
Private Function IsActive(hprog) As Long
Dim hProc, RetVal As Long
Const PROCESS_QUERY_INFORMATION = &H400
Const STILL_ACTIVE = 259
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hprog)
If hProc <> 0 Then
GetExitCodeProcess hProc, RetVal
End If
IsActive = (RetVal = STILL_ACTIVE)
CloseHandle hProc
End Function
Const INFINITE = &HFFFFFFFF
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
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 GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Sub Command1_Click()
Dim pId As Long, pHnd As Long
Const PROCESS_ALL_ACCESS = 0
pId = Shell("Notepad", vbNormalFocus) '现在用的是记事本
Do While IsActive(pId)
DoEvents
Loop
'调用的程序结束时,程序从下面一行继续运行
pHnd = OpenProcess(PROCESS_ALL_ACCESS, False, pId)
If pHnd <> 0 Then
Call WaitForSingleObject(pHnd, INFINITE)
Call CloseHandle(pHnd)
End If
Beep
End Sub
Private Function IsActive(hprog) As Long
Dim hProc, RetVal As Long
Const PROCESS_QUERY_INFORMATION = &H400
Const STILL_ACTIVE = 259
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hprog)
If hProc <> 0 Then
GetExitCodeProcess hProc, RetVal
End If
IsActive = (RetVal = STILL_ACTIVE)
CloseHandle hProc
End Function
dim mAppID as longsub OpenExe(byval strExePath as string)
mAppID=shell(strExePath)
end sub
function AppClosed(byval lAppID as long)as boolean
on error resume next
call appactivate(lAppID)
AppClosed=(err.numeber<>0)
end function