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 PROCESS_HANDLE As Long
Public Function shellAndWait(ByVal PROGRAM_NAME As String, Optional ByVal WINDOW_STYLE As VbAppWinStyle = vbNormalFocus, Optional ByVal MAX_WAIT_SECONDS As Long = 0, Optional ByVal DO_I_CHECK As Byte = 0) As Integer
Dim PROCESS_ID As Long
Dim ERRORLEVEL_CODE As Long
Dim TIME_STARTED As Date
Const PROCESS_QUERY_INFORMATION As Long = &H400
Const STILL_ACTIVE As Long = &H103
Const PROCESS_TERMINATE As Long = &H1
' Start the program.
On Error GoTo ShellError
PROCESS_ID = Shell(PROGRAM_NAME, WINDOW_STYLE)
On Error GoTo 0
DoEvents
' Wait for the program to finish.
' Get the process handle.
PROCESS_HANDLE = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_TERMINATE, 0, PROCESS_ID) ' Or PROCESS_TERMINATE
If PROCESS_HANDLE <> 0 Then
TIME_STARTED = Now
Do
GetExitCodeProcess PROCESS_HANDLE, ERRORLEVEL_CODE
DoEvents
Sleep DELAY_ERRORCODE_CHECK
Loop While ERRORLEVEL_CODE = STILL_ACTIVE
CloseHandle PROCESS_HANDLE
PROCESS_ID = 0
shellAndWait = ERRORLEVEL_CODE
ElseIf DO_I_CHECK = 1 Then
Sleep DELAY_ERRORCODE_CHECK
shellAndWait = shellAndWait(PROGRAM_NAME, WINDOW_STYLE, MAX_WAIT_SECONDS, 1)
End If
Exit Function
ShellError:
stbStatus.Panels(1).text = "ERROR: " + PROGRAM_NAME + " won't run!"
End Function
Private Sub Form_QueryUnload(cancel As Integer, unloadmode As Integer)
If PROCESS_HANDLE <> 0 Then
Dim cool As Integer
Do While TerminateProcess(PROCESS_HANDLE, 0&) <> 0
cool = cool + 1
DoEvents
stbStatus.Panels(1).text = "Terminating process... " + CStr(cool)
Loop
End If
End
End Sub
Please note that it's only a part of program code.
There is still MAX_WAIT_SECONDS variable in shellandwait function. It was used to prevent program from getting stuck but it seems like those programs don't get stuck. At least as far as i tested.
This shell and wait is based on GetExitCodeProcess to check if program is still running and just incase allow program to Terminate process if user closes program when BIIIG file is being recompressed. When user interacts with GUI too much (like menu or listview scrolling) and this function is in DO_I_CHECK mode (1) - means that WE NEED error code [variable or if in other sub] - then program will be restarted as long as proper error code is returned.
There is still MAX_WAIT_SECONDS variable in shellandwait function. It was used to prevent program from getting stuck but it seems like those programs don't get stuck. At least as far as i tested.
This shell and wait is based on GetExitCodeProcess to check if program is still running and just incase allow program to Terminate process if user closes program when BIIIG file is being recompressed. When user interacts with GUI too much (like menu or listview scrolling) and this function is in DO_I_CHECK mode (1) - means that WE NEED error code [variable or if in other sub] - then program will be restarted as long as proper error code is returned.
No comments:
Post a Comment