40 lines
1.7 KiB
QBasic
40 lines
1.7 KiB
QBasic
Attribute VB_Name = "basShellSync"
|
|
Option Explicit
|
|
|
|
Private Const INFINITE = &HFFFFFFFF
|
|
Private Const SYNCHRONIZE = &H100000
|
|
Private Const PROCESS_QUERY_INFORMATION = &H400&
|
|
|
|
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
|
|
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
|
|
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
|
|
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
|
|
Public Function ShellSync(ByVal PathName As String, ByVal WindowStyle As VbAppWinStyle) As Long
|
|
'-----------------------------------------------------------------------------------------------
|
|
'Shell and wait. Return exit code result, raise an
|
|
'exception on any error.
|
|
Dim lngPid As Long
|
|
Dim lngHandle As Long
|
|
Dim lngExitCode As Long
|
|
|
|
lngPid = Shell(PathName, WindowStyle)
|
|
If lngPid <> 0 Then
|
|
lngHandle = OpenProcess(SYNCHRONIZE Or PROCESS_QUERY_INFORMATION, 0, lngPid)
|
|
If lngHandle <> 0 Then
|
|
WaitForSingleObject lngHandle, INFINITE
|
|
If GetExitCodeProcess(lngHandle, lngExitCode) <> 0 Then
|
|
ShellSync = lngExitCode
|
|
CloseHandle lngHandle
|
|
Else
|
|
CloseHandle lngHandle
|
|
Err.Raise &H8004AA00, "ShellSync", "Failed to retrieve exit code, error " & CStr(Err.LastDllError)
|
|
End If
|
|
Else
|
|
Err.Raise &H8004AA01, "ShellSync", "Failed to open child process"
|
|
End If
|
|
Else
|
|
Err.Raise &H8004AA02, "ShellSync", "Failed to Shell child process"
|
|
End If
|
|
|
|
End Function
|