This is a different approach and has a niche. Won't be a solution in all cases. I feel showing a modal window with a progress bar is a better option, but...
If you are calling a function that is asynchronous, but you want to wait until it finishes before the next line of code continues, this may be a workaround for you. This alternative is useful in a GUI environment and may not apply otherwise.
The class provided below enters a modal loop and won't return until a condition is met or the class Abort method is called. This in effect, locks up the calling routine until the loop finishes. It does not prevent re-entrance (like DoEvents doesn't prevent it) unless specified. Do note that if you don't want re-entrance, you need to provide a way out of the loop. That includes giving yourself the ability to call the class Abort method.
Here is the class and I'll include some sample usage afterwards. It only has a few methods. Additionally, each of the 2 Wait methods has an optional parameter array where you can include hWnds that must always be able to receive messages. That list allows you to specify which controls remain active while the modal loop is in effect.
WaitOnObject
There are 3 modality options. These options apply to the mainHwnd parameter passed to the Wait methods.
- reEntry_NoChildren. No windowed controls will be allowed to receive messages
- reEntry_None. All messages (some exceptions) will NOT flow through
- reEntry_All. All messages are allowed to flow through
In the examples, we will use a form-level class. Our class above will be named: cWaitOnAsync. We will also assume there is a command button that offers option to exit modal loop.
Example 1. We'll say we are calling some DLL function that is asynchronous and we do not want the next line of code to continue until the async method finishes. Of course this means that the async method must have a way (an event) to inform you that it failed or succeeded. In that event, we can simply call the class Abort method
Example 2. Let's say the object, you are calling an async method from, has a property value that changes when it is completely finished...
Example 3. You allow the main window to receive messages. That means someone can close the window before the async method finishes. What to do? Here's one possible scenario:
Last but not least, if you allow any re-entrance, you need to address that. Just like you would if you were using DoEvents within some loop. While testing, if you did not give yourself the ability to cancel the modal loop, press Ctrl+Break
If you are calling a function that is asynchronous, but you want to wait until it finishes before the next line of code continues, this may be a workaround for you. This alternative is useful in a GUI environment and may not apply otherwise.
The class provided below enters a modal loop and won't return until a condition is met or the class Abort method is called. This in effect, locks up the calling routine until the loop finishes. It does not prevent re-entrance (like DoEvents doesn't prevent it) unless specified. Do note that if you don't want re-entrance, you need to provide a way out of the loop. That includes giving yourself the ability to call the class Abort method.
Here is the class and I'll include some sample usage afterwards. It only has a few methods. Additionally, each of the 2 Wait methods has an optional parameter array where you can include hWnds that must always be able to receive messages. That list allows you to specify which controls remain active while the modal loop is in effect.
WaitOnObject
Does not release modality until an object's property value changes to a specific value (case-sensitivity applies). If re-entrance is prevented, you must ensure the object's property value can change and you should also ensure you can call the Abort method if needed
WaitUntilAbortDoes not release modality until the class Abort method is called. Same notes above apply here.
AbortReleases the modal loop prematurely and optionally sets a return value for the 2 above methods
IsActiveSimply returns whether the modal loop is active or not
Code:
Option Explicit
' NON-GUI synchronous/modal bridge between calling routine and an asynchronous function call
' For an easy example to visualize, you have a button and in the click event,
' you activate a timer control, but you don't want the next line of code to
' execute until the timer event occurs. By inserting, between those 2 lines of
' code, a call to this class, execution will wait until this class is told to release.
' The timer, in above example, would be the asynchronous function call.
' A GUI solution would not use this class. You would simply display a form modally. That
' form would contain some progress/status information or a simple banner, then call the
' asynchronous function. The form would close when the async function terminated; thereby,
' releasing the line of code that opened the modal form.
' This class replicates, in some ways, the effectiveness of a modal form, without using a form
Public Event Heartbeat(ByVal StartTime As Date, Abort As Boolean)
' Event is raised each time the class checks to see if it should release modality, approx each 500ms
' Changing the Abort parameter to True, will trigger the class Abort method.
' To get this event, declare this class using the keyword: WithEvents
Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function DispatchMessage Lib "user32.dll" Alias "DispatchMessageA" (lpMsg As MSG) As Long
Private Declare Function GetMessage Lib "user32.dll" Alias "GetMessageA" (lpMsg As MSG, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Private Declare Function TranslateMessage Lib "user32.dll" (ByRef lpMsg As MSG) As Long
Private Declare Function SetTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Const WM_TIMER As Long = &H113
Private Const WM_PAINT As Long = &HF&
Private Const WM_PRINT As Long = &H317
Private Const WM_PRINTCLIENT As Long = &H318
Private Const WM_NCPAINT As Long = &H85
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type MSG
hWnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Public Enum ReEntryEnum
reEntry_NoChildren = 0
reEntry_None = 1
reEntry_All = 2
End Enum
Private m_Object As Object
Private m_PropName As String
Private m_PropValue As Variant
Private m_hWndActive As Collection
Private m_Abort As Variant
' This function waits on some object's property value to change to a specific value
' if AllowReEntry parameter is other than reEntry_ALL, then
' if the property is set as a result of a button click or any other action regarding a
' control, ensure you include that control's hWnd in the ParamArray. If not, that
' control is also blocked and cannot trigger an event.
Public Function WaitOnObject(ByVal mainHwnd As Long, _
triggerObject As Object, _
ByVal triggerPropName As String, _
triggerPropValue As Variant, _
ByVal AllowReEntry As ReEntryEnum, _
ParamArray UnblockedHWNDs() As Variant) As Long
' function returns:
' -1 = invalid parameter, 0 = property value set, any other value = Abort called
' mainHwnd: top-level window to have message traffic restricted
' if mainHwnd=0, then no windows (if they apply) will have messages restricted
' triggerObject/PropName/PropValue: object to be checked for property value
' AllowReEntry: optional level of modality, traffic restriction
' UnblockedHWNDs: applies only if mainHwnd non-zero. hWnds without traffic restrictions
If Not m_Object Is Nothing Then ' else busy
WaitOnObject = -1&: Exit Function
ElseIf (triggerObject Is Nothing) Or (triggerPropName = vbNullString) Then
WaitOnObject = -1&: Exit Function
ElseIf triggerObject Is Me Then
WaitOnObject = -1&: Exit Function
End If
On Error Resume Next
m_Abort = (CallByName(triggerObject, triggerPropName, VbGet) = triggerPropValue)
If Err Then ' sanity check. If above produces an error, something is not right with what was passed
Err.Clear
WaitOnObject = -1&: Exit Function
End If
On Error GoTo 0
Dim n As Long
Set m_Object = triggerObject
m_PropName = triggerPropName
m_PropValue = triggerPropValue
m_Abort = Empty
If mainHwnd = 0& Then
AllowReEntry = reEntry_All
ElseIf UBound(UnblockedHWNDs) > -1& Then
On Error Resume Next
Set m_hWndActive = New Collection
For n = 0& To UBound(UnblockedHWNDs)
m_hWndActive.Add 0&, CStr(UnblockedHWNDs(n))
Next
On Error GoTo 0
End If
DoModalLoop mainHwnd, AllowReEntry
If IsEmpty(m_Abort) = False Then WaitOnObject = m_Abort
Set m_Object = Nothing
m_PropValue = Empty
m_PropName = vbNullString
Set m_hWndActive = Nothing
End Function
' This function waits until this class' Abort method is called
' if AllowReEntry parameter is other than reEntry_ALL, then
' if the Abort method is called as a result of a button click or any other action regarding a
' control, ensure you include that control's hWnd in the ParamArray. If not, that
' control is also blocked and cannot trigger an event; therefore, can't call the Abort method.
Public Function WaitUntilAbort(ByVal mainHwnd As Long, ByVal AllowReEntry As ReEntryEnum, ParamArray UnblockedHWNDs() As Variant) As Long
' function returns:
' -1 = invalid parameter, any other value Abort called
If Not m_Object Is Nothing Then ' else busy
WaitUntilAbort = -1&: Exit Function
ElseIf mainHwnd = 0& Then
WaitUntilAbort = -1&: Exit Function
End If
Dim n As Long
If UBound(UnblockedHWNDs) > -1& Then
On Error Resume Next
Set m_hWndActive = New Collection
For n = 0& To UBound(UnblockedHWNDs)
m_hWndActive.Add 0&, CStr(UnblockedHWNDs(n))
Next
On Error GoTo 0
End If
Set m_Object = Me
m_Abort = Empty
DoModalLoop mainHwnd, AllowReEntry
If IsEmpty(m_Abort) = False Then WaitUntilAbort = m_Abort
Set m_Object = Nothing
Set m_hWndActive = Nothing
End Function
Public Sub Abort(Optional ByVal AbortCode As Long = 1&)
' releases the modal loop
' Optionally set an Abort code to be returned by the Wait[xxx] methods
' if set, suggest not using -1 as that is a value to indicate the
' Wait[xxx] methods failed due to an invalid parameter
m_Abort = AbortCode
Set m_Object = Nothing
End Sub
Public Property Get IsActive() As Boolean
' informs you if modal loop is active
IsActive = Not (m_Object Is Nothing)
End Property
Private Sub DoModalLoop(ByVal hWnd As Long, AllowReEntry As ReEntryEnum)
Dim myMsg As MSG, dStartTime As Date
Dim bEat As Boolean, lWnd As Long
If hWnd = 0& Then ' create a temp window; destroyed when loop finishes
lWnd = CreateWindowEx(0&, "Static", vbNullString, 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)
If lWnd = 0& Then
m_Abort = -1&: Exit Sub
End If
Else
lWnd = hWnd
End If
' create timer for hWnd. This ensures message pump activity if thread is otherwise idle
If SetTimer(lWnd, ObjPtr(Me), 500, 0&) = 0 Then
m_Abort = -1&
GoTo ExitRoutine
End If
dStartTime = Now()
' take over the thread message pump
Do While GetMessage(myMsg, 0, 0, 0) > 0 ' Read a message into msg
If myMsg.message = WM_TIMER Then ' Look for the timer we created above
If myMsg.wParam = ObjPtr(Me) Then
bEat = False: RaiseEvent Heartbeat(dStartTime, bEat)
If bEat Then Set m_Object = Nothing
On Error Resume Next
If m_Object Is Nothing Then ' Abort method was clicked
KillTimer lWnd, ObjPtr(Me)
If IsEmpty(m_Abort) Then m_Abort = 1&
Exit Do
ElseIf m_PropName <> vbNullString Then ' test object property value
If CallByName(m_Object, m_PropName, VbGet) = m_PropValue Then
KillTimer lWnd, ObjPtr(Me)
Exit Do
End If
End If
If Err Then Err.Clear
On Error GoTo 0
End If
End If
' pre-decisions: allow message through or not
If AllowReEntry = reEntry_None Then
bEat = True
ElseIf AllowReEntry = reEntry_NoChildren Then
bEat = Not (myMsg.hWnd = lWnd)
Else
bEat = False
End If
' refine decisions
If bEat Then
Select Case myMsg.message ' allow these pain-related message through
Case WM_TIMER, WM_PAINT, WM_NCPAINT, WM_PRINT, WM_PRINTCLIENT
bEat = False
Case Else
If Not m_hWndActive Is Nothing Then
On Error Resume Next ' allow messages for specified hWnds
bEat = Not (m_hWndActive.Item(CStr(myMsg.hWnd)) = 0&)
If Err Then Err.Clear
On Error GoTo 0
End If
End Select
End If
If bEat = False Then
TranslateMessage myMsg
DispatchMessage myMsg
End If
Loop
ExitRoutine:
If hWnd = 0& Then DestroyWindow lWnd
End Sub- reEntry_NoChildren. No windowed controls will be allowed to receive messages
- reEntry_None. All messages (some exceptions) will NOT flow through
- reEntry_All. All messages are allowed to flow through
In the examples, we will use a form-level class. Our class above will be named: cWaitOnAsync. We will also assume there is a command button that offers option to exit modal loop.
Code:
' in the declarations section...
Private m_AsyncPauser As cWaitOnAsyncCode:
Private Sub Command1_Click()
Set m_AsyncPauser = New cWaitOnAsyc
' call the async method which has events giving you status of its progress
ourAsyncObject.DoSomeAsyncCall
cmdAbort.Enabled = True ' give user option to cancel
' wait on above call
Select Case m_AsyncPauser.WaitUntilAbort(Me.hWnd, reEntry_NoChildren, cmdAbort.hWnd)
Case -1 ' bad parameter passed above
Case 0 ' async method finished normally
Case Else ' cWaitOnAsync.Abort was called
End Select
Set m_AsyncPauser = Nothing: cmdAbort.Enabled = False
End Sub
Private Sub ourAsyncMethodEvent_Finished()
m_AsyncPauser.Abort 0
End Sub
Private Sub ourAsyncMethodEvent_Failed()
m_AsyncPauser.Abort 1
End Sub
Private Sub cmdAbort_Click()
' user aborting, so call the method of the async object to abort it, then...
m_AsyncPauser.Abort 1& ' any non-zero value to indicate aborting vs succeeding
End SubCode:
Private Sub Command1_Click()
Set m_AsyncPauser = New cWaitOnAsyc
' call the async method which has a "State" property that changes to -1 when done
ourAsyncObject.DoSomeAsyncCall
cmdAbort.Enabled = True ' give user option to cancel
' wait on above call
Select Case m_AsyncPauser.WaitOnObject(Me.hWnd, ourAsyncObject, "State", -1, _
reEntry_NoChildren, cmdAbort.hWnd)
Case -1 ' bad parameter passed above
Case 0 ' async method finished normally
Case Else ' cWaitOnAsync.Abort was called
End Select
Set m_AsyncPauser = Nothing: cmdAbort.Enabled = False
End Sub
Private Sub cmdAbort_Click()
' user aborting, so call the method of the async object to abort it, then...
m_AsyncPauser.Abort 1& ' any non-zero value to indicate aborting vs succeeding
End SubCode:
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Not m_AsyncPauser Is Nothing Then
If m_AsyncPauser.IsActive = True Then
MsgBox "Application is busy. Cancel current operation and try again", vbInformation + vbOKOnly
Cancel = True
End If
End If
End Sub
