Synchronous Shell Blocks Window Refresh

zendomaniac,

Add DoEvents to your loop.

--Robert E. Sponaugle, Jr.

Thanx for your comment Mr. Sponaugle.

But can u tell me where specifically should I add "DoEvents" because I don't think I have any loops!

-- zendomaniac

Nope! I still have the same problem!

I have placed the "ExecCmd" function in a module and I have used the "clsThreading" class wrapper.

<start code>

Sub Form_Click()
   Dim x As New clsThreading
   Dim y As Long
   y = x.CreateNewThread(ExecCmd("notepad.exe"), 0, True)
End Sub

<end code>

Did you ever come up with a solution to this? I'm experiencing the same problem.

PLavelle,

Here is my solution for this problem:

< Start Code >


Option Explicit

Private Const STATUS_TIMEOUT = &H102&
Private Const INFINITE = -1& ' Infinite interval
Private Const QS_KEY = &H1&
Private Const QS_MOUSEMOVE = &H2&
Private Const QS_MOUSEBUTTON = &H4&
Private Const QS_POSTMESSAGE = &H8&
Private Const QS_TIMER = &H10&
Private Const QS_PAINT = &H20&
Private Const QS_SENDMESSAGE = &H40&
Private Const QS_HOTKEY = &H80&
Private Const QS_ALLINPUT = (QS_SENDMESSAGE Or QS_PAINT _
        Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON _
        Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)
Private Declare Function MsgWaitForMultipleObjects Lib "user32" _
        (ByVal nCount As Long, pHandles As Long, _
        ByVal fWaitAll As Long, ByVal dwMilliseconds _
        As Long, ByVal dwWakeMask As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Type STARTUPINFO
      cb As Long
      lpReserved As String
      lpDesktop As String
      lpTitle As String
      dwX As Long
      dwY As Long
      dwXSize As Long
      dwYSize As Long
      dwXCountChars As Long
      dwYCountChars As Long
      dwFillAttribute As Long
      dwFlags As Long
      wShowWindow As Integer
      cbReserved2 As Integer
      lpReserved2 As Long
      hStdInput As Long
      hStdOutput As Long
      hStdError As Long
   End Type

   Private Type PROCESS_INFORMATION
      hProcess As Long
      hThread As Long
      dwProcessID As Long
      dwThreadID As Long
   End Type

   Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
      hHandle As Long, ByVal dwMilliseconds As Long) As Long

   Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
      lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
      lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
      ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
      ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
      lpStartupInfo As STARTUPINFO, lpProcessInformation As _
      PROCESS_INFORMATION) As Long

   Private Declare Function TerminateProcess Lib "kernel32" _
         (ByVal hProcess As Long, _
         ByVal uExitCode As Long) As Long

   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 Const NORMAL_PRIORITY_CLASS = &H20&
   Private Const STARTF_USESHOWWINDOW = &H1&
   
   Public Enum sw_window
        SW_HIDE = 0
        SW_MAX = 10
        SW_MAXIMIZE = 3
        SW_MINIMIZE = 6
        SW_NORMAL = 1
   End Enum

Public Function MsgWaitObj(Interval As Long, _
            Optional hObj As Long = 0&, _
            Optional nObj As Long = 0&) As Long
Dim T As Long, T1 As Long
If Interval <> INFINITE Then
    T = GetTickCount()
    On Error Resume Next
    T = T + Interval

    If Err <> 0& Then
        If T > 0& Then
            T = ((T + &H80000000) _
            + Interval) + &H80000000
        Else
            T = ((T - &H80000000) _
            + Interval) - &H80000000
        End If
    End If
    On Error GoTo 0

Else
    T1 = INFINITE
End If
Do
    If Interval <> INFINITE Then
        T1 = GetTickCount()
        On Error Resume Next
     T1 = T - T1

        If Err <> 0& Then
            If T > 0& Then
                T1 = ((T + &H80000000) _
                - (T1 - &H80000000))
            Else
                T1 = ((T - &H80000000) _
                - (T1 + &H80000000))
            End If
        End If
        On Error GoTo 0

        If IIf((T1 Xor Interval) > 0&, _
            T1 > Interval, T1 < 0&) Then


            MsgWaitObj = STATUS_TIMEOUT
            Exit Function
        End If
    End If


    MsgWaitObj = MsgWaitForMultipleObjects(nObj, _
            hObj, 0&, T1, QS_ALLINPUT)

    DoEvents
    If MsgWaitObj <> nObj Then Exit Function

Loop
End Function

Public Function ExecCmd(cmdline As String, window As sw_window, interactive As _
Boolean) As Long

      Dim proc As PROCESS_INFORMATION
      Dim start As STARTUPINFO
      Dim ret As Long

      ' Initialize the STARTUPINFO structure:
      start.wShowWindow = window
      start.dwFlags = STARTF_USESHOWWINDOW
      start.cb = Len(start)

      ' Start the shelled application:
      ret = CreateProcessA(vbNullString, cmdline, 0&, 0&, 1&, _
         NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)
       
      If interactive = True Then

      ' Wait for the shelled application to finish (INTERACTIVE):
         ret = MsgWaitObj(INFINITE, proc.hProcess, 1&)

      Else

      ' Wait for the shelled application to finish (NON-INTERACTIVE):
         ret = WaitForSingleObject(proc.hProcess, INFINITE)
     
      End If

      ' Terminate the shelled application - just incase if you had to!
      ' Warning: Use this with caution!
      ' This function only terminates the CURRENT shelled
      ' application started by "CreateProcessA".
      ' *******************************************
      '  Call TerminateProcess(proc.hProcess, 0&)

         Call GetExitCodeProcess(proc.hProcess, ret)
         Call CloseHandle(proc.hThread)
         Call CloseHandle(proc.hProcess)
         ExecCmd = ret
         
   End Function


< End Code >

Function "ExecCmd" takes 3 options. The first option is the path/executable of the shell application, the second is the vb_window status (maximize, minimize, normal, hide, or max) and the last one is whether the vb application calling the shell application will be interactive or not.

< For Example >

Dim x As Long
x = ExecCmd("notepad", SW_NORMAL, True)
MsgBox x

< End Example >

Hope it helps you !

-- Zendomaniac

For the above code/post:

A big (full) thank goes to:

- danths (for the portion of the code which hides, maximizes, minimizes the shell application)
- Sergey Merzlikin (for the function "MsgWaitForMultipleObjects" which waits for the shell application to finish without hanging the vb app)

A partial thank goes to Microsoft for providing us a HALF-ASSED solution to the Shell Function!

-- zendomaniac

Thanks zendomaniac.