[Last Call] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 781
  • Last Modified:

Shell Document and Wait

I have this function which shells a document

Public Function ShellDocument(sDoc As String, Optional sParams As String = "")
   
    Dim Scr_hDC As Integer
   
    SetContext "Shelling Document " & sDoc
    Scr_hDC = GetDesktopWindow()
    ShellDocument = ShellExecute(Scr_hDC, "Open", sDoc, sParams, "C:\", SW_SHOWNORMAL)
   
End Function

.... and I have this function which shells an EXE and waits for it to finish........

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const PROCESS_QUERY_INFORMATION = 1024
'

Public Sub ShellWait(sPath As String, lSecondsTimeOut As Long)
   
    Dim hProcess As Long, hOpenProcess As Long
    Dim lCount As Long
   
    gsContext = "Waiting for " & sPath
    hProcess = Shell(sPath, vbNormalFocus)
    Do
        'Open a handle to the process requesting query permissions
        hOpenProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 0, hProcess)
        'If we were successful
        If hOpenProcess <> 0 Then
            CloseHandle hOpenProcess
        Else
            Sleep 100               ' Safety net for disk writes etc
            Exit Sub
        End If
        Sleep 100                                                   ' one tenth of a second
        lCount = lCount + 1
        DoEvents
        If lCount > 10 * lSecondsTimeOut And lSecondsTimeOut > 0 Then Exit Sub               ' 10 seconds
    Loop
   
End Sub

......... what I want is to merge the two somehow to give me a ShellDocumentAndWait function

Any ideas ?










0
plq
Asked:
plq
  • 3
  • 3
  • 2
  • +1
2 Solutions
 
[ fanpages ]IT Services ConsultantCommented:
Hi,

Have you tried using the ShellExecuteEx(), WaitForInputIdle(), & WaitForSingleObject() API calls instead?

I could post some code that works in Excel VBA & a suggestion to change it for Visual Basic if you wish.

BFN,

fp.
0
 
plqAuthor Commented:
Excel code would be fine. Please post it !

thanks
0
 
ADSaundersCommented:
Hi,
Try This Using ShellExecuteEX and WaitForSingleProcess. Declarations Follow.
This is a slightly modified extract of an existing application. In my case, I'm just checking whether the process has finished in a timer loop (not waiting) but it should work.

.. Alan

          Dim ProcData As SHELLEXECUTEINFO
          Dim DStartIn As String  ' Start In folder
          Dim DExec As String     ' Executable or document name
          Dim DParams As String ' Any parameters
          Dim t as Long ' WaitforSingleObject Timeout (ms)
          With ProcData
              .cbSize = Len(ProcData)
              .fMask = SEE_MASK_NOCLOSEPROCESS
              .hwnd = GetDesktopWindow()
              .lpVerb = "open"
              .lpFile = DExec
              .lpParameters = DParams
              .lpDirectory = DStartIn
              .nShow = SW_HIDE
          End With
          lReturnCode = ShellExecuteEx(ProcData)
          If lReturnCode = 0 Then
              hProcess = 0
          Else
              hProcess = ProcData.hProcess
              Do
                  j = WaitForSingleObject(hProcess, t) ' t is the time in milliseconds that you wish to wait
                  If j <> WAIT_TIMEOUT Then ' Process has finished
                      Exit Do
                  End If
              Loop
          End If
' Declarations
Public Type SHELLEXECUTEINFO
    cbSize As Long
    fMask As Long
    hwnd As Long
    lpVerb As String
    lpFile As String
    lpParameters As String
    lpDirectory As String
    nShow As Long
    hInstApp As Long
    lpIDList As Long
    lpClass As String
    hkeyClass As Long
    dwHotKey As Long
    hIcon As Long
    hProcess As Long
End Type
Public Declare Function ShellExecuteEx Lib "shell32.dll" _
                         Alias "ShellExecuteExA" _
                        (lpExecInfo As SHELLEXECUTEINFO _
                        ) As Long
Public Declare Function GetDesktopWindow Lib "user32.dll" _
                         () As Long
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
ADSaundersCommented:
Sorry,
> .nShow = SW_HIDE
In your case this should probably be
   .nShow = SW_NORMAL

See the values available in the ShowWindow API.

.. Alan
0
 
[ fanpages ]IT Services ConsultantCommented:
Hi,

My Excel code follows.

Alan's posting above uses a similar approach.

Option Explicit

' ----------------------------------------------------------------------------------------------
' Experts Exchange Question:
' Home \ All Topics \ Programming \ Languages \ Visual Basic
' http://www.experts-exchange.com/Programming/Programming_Languages/Visual_Basic/Q_21418540.html
' Shell Document and Wait
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 10 May 2005
' ----------------------------------------------------------------------------------------------

Private lngErr_Number                                   As Long
Private strErr_Description                              As String

Private Declare Function CloseHandle Lib "kernel32" _
                  (ByVal hObject As Long) As Long

Private Declare Function FindWindow _
                     Lib "user32" _
                   Alias "FindWindowA" _
                 (ByVal lpClassName As String, _
                  ByVal lpWindowName As String) As Long

'Private Declare Function GetDesktopWindow _
                    Lib "user32.dll" _
                        () As Long
                       
Private Declare Function ShellExecuteEx _
                     Lib "shell32.dll" _
                   Alias "ShellExecuteExA" _
                  (ByRef lpExecInfo As udtSHELLEXECUTE_INFO) As Long

Private Declare Function WaitForInputIdle _
                     Lib "user32" _
                  (ByVal hProcess As Long, _
                   ByVal dwMilliseconds As Long) As Long
                   
Private Declare Function WaitForSingleObject _
                     Lib "kernel32.dll" _
                  (ByVal hHandle As Long, _
                   ByVal dwMilliseconds As Long) As Long

Private Type udtSHELLEXECUTE_INFO
  cbSize                                                As Long
  fMask                                                 As Long
  hwnd                                                  As Long
  lpVerb                                                As String
  lpFile                                                As String
  lpParameters                                          As String
  lpDirectory                                           As String
  nShow                                                 As Long
  hInstApp                                              As Long
  lpIDList                                              As Long
  lpClass                                               As String
  hkeyClass                                             As Long
  dwHotKey                                              As Long
  hIcon                                                 As Long
  hProcess                                              As Long
End Type

Private Const lngShellExecute_ERR0R_ACCESS_DENIED       As Long = 5&
Private Const lngShellExecute_ERROR_BAD_ASSOCIATION     As Long = 27&
Private Const lngShellExecute_ERROR_BAD_FORMAT          As Long = 11&
Private Const lngShellExecute_ERROR_DDE_BUSY            As Long = 30&
Private Const lngShellExecute_ERROR_DDE_FAIL            As Long = 29&
Private Const lngShellExecute_ERROR_DDE_TIMEOUT         As Long = 28&
Private Const lngShellExecute_ERROR_DLL_NOT_FOUND       As Long = 32&
Private Const lngShellExecute_ERROR_FILE_NOT_FOUND      As Long = 2&
Private Const lngShellExecute_ERROR_NO_ASSOCIATION      As Long = 31&
Private Const lngShellExecute_ERROR_OUT_OF_MEMORY       As Long = 8&
Private Const lngShellExecute_ERROR_PATH_NOT_FOUND      As Long = 3&
Private Const lngShellExecute_ERROR_SHARING_VIOLATION   As Long = 26&

Public Const lngSW_HIDE                                 As Long = 0&    ' vbHide
Public Const lngSW_MAXIMIZE                             As Long = 3&
Public Const lngSW_MINIMIZE                             As Long = 6&    ' vbMinimizedNoFocus
Public Const lngSW_RESTORE                              As Long = 9&
Public Const lngSW_SHOW                                 As Long = 5&
Public Const lngSW_SHOW_MAXIMIZED                       As Long = 3&    ' vbMaximizedFocus
Public Const lngSW_SHOW_MINIMIZED                       As Long = 2&    ' vbMinimizedFocus
Public Const lngSW_SHOW_MINIMIZED_NO_ACTIVATE           As Long = 7&
Public Const lngSW_SHOW_NORMAL_NO_ACTIVATE              As Long = 8&
Public Const lngSW_SHOW_NO_ACTIVATE                     As Long = 4&    ' vbNormalNoFocus
Public Const lngSW_SHOW_NORMAL                          As Long = 1&    ' vbNormalFocus
Public Function blnShell_ExecuteEx(ByVal strURL As String, _
                                   Optional ByVal strParameters As String = vbNullString, _
                                   Optional strDefault_Directory As String = "", _
                                   Optional lngShow_Cmd As Long = lngSW_SHOW_NORMAL) As Boolean

' ----------------------------------------------------------------------------------------------
' Experts Exchange Question:
' Home \ All Topics \ Programming \ Languages \ Visual Basic
' http://www.experts-exchange.com/Programming/Programming_Languages/Visual_Basic/Q_21418540.html
' Shell Document and Wait
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 10 May 2005
' ----------------------------------------------------------------------------------------------

  Dim blnReturn                                         As Boolean
  Dim blnWend                                           As Boolean
  Dim hwnd_XLMain                                       As Long
  Dim lngHandle                                         As Long
  Dim lngMilliseconds                                   As Long
  Dim udtSHELLEXECUTE_INFO                              As udtSHELLEXECUTE_INFO
 
  On Error GoTo Err_blnShell_ExecuteEx
 
  Const lngSEE_MASK_FLAG_DDEWAIT                        As Long = &H100
  Const lngSEE_MASK_NOCLOSEPROCESS                      As Long = &H40
  Const lngWaitFor_INFINITE                             As Long = &HFFFF
  Const lngWaitFor_WAIT_TIMEOUT                         As Long = &H102

  blnReturn = False
 
  If Len(Trim$(strDefault_Directory)) = 0 Then
     strDefault_Directory = CurDir
  End If

' lngMilliseconds = 5& * 60& * 1000&                                                    ' 5 minutes
  lngMilliseconds = 0&
 
  hwnd_XLMain = FindWindow("XLMAIN", Application.Caption)
 
' Use call to GetDesktopWindow() for use in Visual Basic...
' hwnd = GetDesktopWindow()
 
  udtSHELLEXECUTE_INFO.cbSize = Len(udtSHELLEXECUTE_INFO)
  udtSHELLEXECUTE_INFO.fMask = lngSEE_MASK_FLAG_DDEWAIT Or lngSEE_MASK_NOCLOSEPROCESS   ' Use optional hProcess element
  udtSHELLEXECUTE_INFO.hwnd = hwnd_XLMain                                               ' Handle to calling process window
  udtSHELLEXECUTE_INFO.lpVerb = "open"
  udtSHELLEXECUTE_INFO.lpFile = strURL
  udtSHELLEXECUTE_INFO.lpParameters = strParameters
  udtSHELLEXECUTE_INFO.lpDirectory = strDefault_Directory
  udtSHELLEXECUTE_INFO.nShow = lngShow_Cmd
   
  udtSHELLEXECUTE_INFO.lpIDList = 0&
  udtSHELLEXECUTE_INFO.lpClass = vbNullString
  udtSHELLEXECUTE_INFO.hkeyClass = 0&
  udtSHELLEXECUTE_INFO.dwHotKey = 0&
  udtSHELLEXECUTE_INFO.hIcon = 0&
  udtSHELLEXECUTE_INFO.hProcess = 0&
   
  lngHandle = ShellExecuteEx(udtSHELLEXECUTE_INFO)
 
  Select Case (lngHandle)
 
      Case (0&)
          Select Case (udtSHELLEXECUTE_INFO.hInstApp)
              Case (lngShellExecute_ERR0R_ACCESS_DENIED)
              Case (lngShellExecute_ERROR_BAD_ASSOCIATION)
              Case (lngShellExecute_ERROR_BAD_FORMAT)
              Case (lngShellExecute_ERROR_DDE_BUSY)
              Case (lngShellExecute_ERROR_DDE_FAIL)
              Case (lngShellExecute_ERROR_DDE_TIMEOUT)
              Case (lngShellExecute_ERROR_DLL_NOT_FOUND)
              Case (lngShellExecute_ERROR_FILE_NOT_FOUND)
              Case (lngShellExecute_ERROR_NO_ASSOCIATION)
              Case (lngShellExecute_ERROR_OUT_OF_MEMORY)
              Case (lngShellExecute_ERROR_PATH_NOT_FOUND)
              Case (lngShellExecute_ERROR_SHARING_VIOLATION)
              Case Else
          End Select

      Case Else
     
          Call WaitForInputIdle(udtSHELLEXECUTE_INFO.hProcess, lngWaitFor_INFINITE)

          blnWend = False
         
          While (Not (blnWend))
       
              DoEvents
           
              blnWend = (WaitForSingleObject(udtSHELLEXECUTE_INFO.hProcess, lngMilliseconds) <> lngWaitFor_WAIT_TIMEOUT)
           
          Wend
       
          Call CloseHandle(udtSHELLEXECUTE_INFO.hProcess)
         
          blnReturn = True
         
  End Select

Exit_blnShell_ExecuteEx:

  On Error Resume Next
 
  blnShell_ExecuteEx = blnReturn
 
  Exit Function
 
Err_blnShell_ExecuteEx:

  lngErr_Number = Err.Number
  strErr_Description = Err.Description
 
  On Error Resume Next
 
  MsgBox "ERROR #" & CStr(lngErr_Number) & vbCrLf & vbLf & strErr_Description, vbExclamation Or vbOKOnly, ActiveWorkbook.Name

  blnReturn = False
 
  Resume Exit_blnShell_ExecuteEx
 
End Function


BFN,

fp.
0
 
vinnyd79Commented:
Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) 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 GetExitCodeProcess Lib "Kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
Const STILL_ACTIVE = &H103
Const PROCESS_QUERY_INFORMATION = &H400

Private Function ShellDocumentAndWait(DocumentName, Optional WindowStyle As VbAppWinStyle = vbNormalFocus) As Double
Dim hProcess As Long, RetVal As Long, strEXE As String * 255
Call FindExecutable(DocumentName, "", strEXE)
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(Left$(strEXE, InStr(strEXE, Chr$(0)) - 1) & " " & DocumentName, WindowStyle))
    Do
        GetExitCodeProcess hProcess, RetVal
        DoEvents: Sleep 100
    Loop While RetVal = STILL_ACTIVE
End Function

Private Sub Command1_Click()
ShellDocumentAndWait "C:\Test.xls", vbNormalFocus
MsgBox "Document has been closed!"
End Sub
0
 
plqAuthor Commented:
vinnyd79 - Thanks for the compact solution, but I didn't fancy the assumption that %1 would ALWAYS be the parameter

So, I took ADSaunders solution, added a few constants and cleaned up a bit, and that worked fine.

Thanks to everyone for helping.
0
 
ADSaundersCommented:
Thanks,
.. Alan
0
 
vinnyd79Commented:
%1 ?
0
 
plqAuthor Commented:
vinny: Shell app & " " & param. Its assuming that the first param is correct whereas the reality might be "app /parama /paramb /document " & param

I think shellexecuteex insulates you from this.
0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 3
  • 3
  • 2
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now