home *** CD-ROM | disk | FTP | other *** search
/ CD Shareware Magazine 1999 April / CD_Shareware_Magazine_31.iso / Free / Prg / Shell32.exe / Shell32.bas next >
Encoding:
BASIC Source File  |  1997-11-24  |  8.1 KB  |  240 lines
  1. Attribute VB_Name = "Shell32"
  2.  
  3. ' ****************************************************************
  4. '  Shell32.Bas, Copyright ⌐1996-97 Karl E. Peterson
  5. ' ****************************************************************
  6. '  You are free to use this code within your own applications, but you
  7. '  are expressly forbidden from selling or otherwise distributing this
  8. '  source code without prior written consent.
  9. ' ****************************************************************
  10. '  Three methods to "Shell and Wait" under Win32.
  11. '  One deals with the infamous "Finished" behavior of Win95.
  12. '  Fourth method that simply shells and returns top-level hWnd.
  13. ' ****************************************************************
  14. Option Explicit
  15.  
  16. Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
  17. Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
  18. Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
  19. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  20. Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
  21. Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
  22. Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
  23. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  24. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
  25. Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
  26. Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
  27. Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
  28.  
  29. Private Const STILL_ACTIVE = &H103
  30. Private Const PROCESS_QUERY_INFORMATION = &H400
  31. Private Const SYNCHRONIZE = &H100000
  32.  
  33. Public Const WAIT_FAILED = -1&        'Error on call
  34. Public Const WAIT_OBJECT_0 = 0        'Normal completion
  35. Public Const WAIT_ABANDONED = &H80&   '
  36. Public Const WAIT_TIMEOUT = &H102&    'Timeout period elapsed
  37. Public Const IGNORE = 0               'Ignore signal
  38. Public Const INFINITE = -1&           'Infinite timeout
  39.  
  40. Public Const SW_HIDE = 0
  41. Public Const SW_SHOWNORMAL = 1
  42. Public Const SW_SHOWMINIMIZED = 2
  43. Public Const SW_SHOWMAXIMIZED = 3
  44. Public Const SW_SHOWNOACTIVATE = 4
  45. Public Const SW_SHOW = 5
  46. Public Const SW_MINIMIZE = 6
  47. Public Const SW_SHOWMINNOACTIVE = 7
  48. Public Const SW_SHOWNA = 8
  49. Public Const SW_RESTORE = 9
  50.  
  51. Private Const WM_CLOSE = &H10
  52. Private Const GW_HWNDNEXT = 2
  53. Private Const GW_OWNER = 4
  54.  
  55. Public Function ShellAndWait(ByVal JobToDo As String, Optional ExecMode, Optional TimeOut) As Long
  56.    '
  57.    ' Shells a new process and waits for it to complete.
  58.    ' Calling application is totally non-responsive while
  59.    ' new process executes.
  60.    '
  61.    Dim ProcessID As Long
  62.    Dim hProcess As Long
  63.    Dim nRet As Long
  64.    Const fdwAccess = SYNCHRONIZE
  65.  
  66.    If IsMissing(ExecMode) Then
  67.       ExecMode = vbMinimizedNoFocus
  68.    Else
  69.       If ExecMode < vbHide Or ExecMode > vbMinimizedNoFocus Then
  70.          ExecMode = vbMinimizedNoFocus
  71.       End If
  72.    End If
  73.  
  74.    On Error Resume Next
  75.       ProcessID = Shell(JobToDo, CLng(ExecMode))
  76.       If Err Then
  77.          ShellAndWait = vbObjectError + Err.Number
  78.          Exit Function
  79.       End If
  80.    On Error GoTo 0
  81.  
  82.    If IsMissing(TimeOut) Then
  83.       TimeOut = INFINITE
  84.    End If
  85.  
  86.    hProcess = OpenProcess(fdwAccess, False, ProcessID)
  87.    nRet = WaitForSingleObject(hProcess, CLng(TimeOut))
  88.    Call CloseHandle(hProcess)
  89.  
  90.    Select Case nRet
  91.       Case WAIT_TIMEOUT: Debug.Print "Timed out!"
  92.       Case WAIT_OBJECT_0: Debug.Print "Normal completion."
  93.       Case WAIT_ABANDONED: Debug.Print "Wait Abandoned!"
  94.       Case WAIT_FAILED: Debug.Print "Wait Error:"; Err.LastDllError
  95.    End Select
  96.    ShellAndWait = nRet
  97. End Function
  98.  
  99. Public Function ShellAndLoop(ByVal JobToDo As String, Optional ExecMode) As Long
  100.    '
  101.    ' Shells a new process and waits for it to complete.
  102.    ' Calling application is responsive while new process
  103.    ' executes. It will react to new events, though execution
  104.    ' of the current thread will not continue.
  105.    '
  106.    Dim ProcessID As Long
  107.    Dim hProcess As Long
  108.    Dim nRet As Long
  109.    Const fdwAccess = PROCESS_QUERY_INFORMATION
  110.  
  111.    If IsMissing(ExecMode) Then
  112.       ExecMode = vbMinimizedNoFocus
  113.    Else
  114.       If ExecMode < vbHide Or ExecMode > vbMinimizedNoFocus Then
  115.          ExecMode = vbMinimizedNoFocus
  116.       End If
  117.    End If
  118.  
  119.    On Error Resume Next
  120.       ProcessID = Shell(JobToDo, CLng(ExecMode))
  121.       If Err Then
  122.          ShellAndLoop = vbObjectError + Err.Number
  123.          Exit Function
  124.       End If
  125.    On Error GoTo 0
  126.  
  127.    hProcess = OpenProcess(fdwAccess, False, ProcessID)
  128.    Do
  129.       GetExitCodeProcess hProcess, nRet
  130.       DoEvents
  131.       Sleep 100
  132.    Loop While nRet = STILL_ACTIVE
  133.    Call CloseHandle(hProcess)
  134.  
  135.    ShellAndLoop = nRet
  136. End Function
  137.  
  138. Public Function ShellAndClose(ByVal JobToDo As String, Optional ExecMode) As Long
  139.    '
  140.    ' Shells a new process and waits for it to complete.
  141.    ' Calling application is responsive while new process
  142.    ' executes. It will react to new events, though execution
  143.    ' of the current thread will not continue.
  144.    '
  145.    ' Will close a DOS box when Win95 doesn't. More overhead
  146.    ' than ShellAndLoop but useful when needed.
  147.    '
  148.    Dim ProcessID As Long
  149.    Dim PID As Long
  150.    Dim hProcess As Long
  151.    Dim hWndJob As Long
  152.    Dim nRet As Long
  153.    Dim TitleTmp As String
  154.    Const fdwAccess = PROCESS_QUERY_INFORMATION
  155.  
  156.    If IsMissing(ExecMode) Then
  157.       ExecMode = vbMinimizedNoFocus
  158.    Else
  159.       If ExecMode < vbHide Or ExecMode > vbMinimizedNoFocus Then
  160.          ExecMode = vbMinimizedNoFocus
  161.       End If
  162.    End If
  163.  
  164.    On Error Resume Next
  165.       ProcessID = Shell(JobToDo, CLng(ExecMode))
  166.       If Err Then
  167.          ShellAndClose = vbObjectError + Err.Number
  168.          Exit Function
  169.       End If
  170.    On Error GoTo 0
  171.  
  172.    hWndJob = FindWindow(vbNullString, vbNullString)
  173.    Do Until hWndJob = 0
  174.       If GetParent(hWndJob) = 0 Then
  175.          Call GetWindowThreadProcessId(hWndJob, PID)
  176.          If PID = ProcessID Then Exit Do
  177.       End If
  178.       hWndJob = GetWindow(hWndJob, GW_HWNDNEXT)
  179.    Loop
  180.  
  181.    hProcess = OpenProcess(fdwAccess, False, ProcessID)
  182.    Do
  183.       TitleTmp = Space(256)
  184.       nRet = GetWindowText(hWndJob, TitleTmp, Len(TitleTmp))
  185.       If nRet Then
  186.          TitleTmp = UCase(Left(TitleTmp, nRet))
  187.          If InStr(TitleTmp, "FINISHED") = 1 Then
  188.             Call SendMessage(hWndJob, WM_CLOSE, 0, 0)
  189.          End If
  190.       End If
  191.  
  192.       GetExitCodeProcess hProcess, nRet
  193.       DoEvents
  194.       Sleep 100
  195.    Loop While nRet = STILL_ACTIVE
  196.    Call CloseHandle(hProcess)
  197.  
  198.    ShellAndClose = nRet
  199. End Function
  200.  
  201. Public Function hWndShell(ByVal JobToDo As String, Optional ExecMode) As Long
  202.    '
  203.    ' Shells a new process and returns the hWnd
  204.    ' of its main window.
  205.    '
  206.    Dim ProcessID As Long
  207.    Dim PID As Long
  208.    Dim hProcess As Long
  209.    Dim hWndJob As Long
  210.  
  211.    If IsMissing(ExecMode) Then
  212.       ExecMode = vbMinimizedNoFocus
  213.    Else
  214.       If ExecMode < vbHide Or ExecMode > vbMinimizedNoFocus Then
  215.          ExecMode = vbMinimizedNoFocus
  216.       End If
  217.    End If
  218.  
  219.    On Error Resume Next
  220.       ProcessID = Shell(JobToDo, CLng(ExecMode))
  221.       If Err Then
  222.          hWndShell = 0
  223.          Exit Function
  224.       End If
  225.    On Error GoTo 0
  226.  
  227.    hWndJob = FindWindow(vbNullString, vbNullString)
  228.    Do While hWndJob <> 0
  229.       If GetParent(hWndJob) = 0 Then
  230.          Call GetWindowThreadProcessId(hWndJob, PID)
  231.          If PID = ProcessID Then
  232.             hWndShell = hWndJob
  233.             Exit Do
  234.          End If
  235.       End If
  236.       hWndJob = GetWindow(hWndJob, GW_HWNDNEXT)
  237.    Loop
  238. End Function
  239.  
  240.