This is a different approach and has a niche. Won't be a solution in all cases.
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 controls will be allowed to receive messages
- reEntry_None. Absolutely no messages will be allowed to be received by any window (some exceptions)
- reEntry_All. All messages are allowed to flow through
In the examples, we will use a form-level class. Our class above is named: cWaitOnAsync. We will also assume there is a command button or menu 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 turns True 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 and optionally sets a return value for the 2 above methods
IsActiveSimply returns whether the modal loop is active or not
Code:
Option Explicit
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 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 Long
' 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, _
AllowReEntry As ReEntryEnum, _
ParamArray UnblockedHWNDs() As Variant) As Long
' function returns:
' -1 = invalid parameter, 0 = property value set, any other value = Abort called
If mainHwnd = 0& Then
WaitOnObject = -1&: Exit Function
End If
If (triggerObject Is Nothing) Or (triggerPropName = vbNullString) Then
WaitOnObject = -1&: Exit Function
End If
If triggerObject Is Me Then
WaitOnObject = -1&: Exit Function
End If
Dim n As Long
Set m_Object = triggerObject
m_PropName = triggerPropName
m_PropValue = triggerPropValue
m_Abort = Empty
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
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, AllowReEntry As ReEntryEnum, ParamArray UnblockedHWNDs() As Variant) As Long
' function returns:
' -1 = invalid parameter, any other value Abort called
If mainHwnd = 0& Then
WaitUntilAbort = -1&: Exit Function
End If
Dim n As Long
Set m_Object = Me
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
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(hWnd As Long, AllowReEntry As ReEntryEnum)
If SetTimer(hWnd, ObjPtr(Me), 250, 0&) = 0 Then Exit Sub
' function freezes current executable line in calling window
' until our window loses focus or is closed
On Error Resume Next
Dim myMsg As MSG, bEat As Boolean
'SetCapture m_hWnd
Do While GetMessage(myMsg, 0, 0, 0) > 0 ' Read a message into msg
If myMsg.message = WM_TIMER Then
If myMsg.wParam = ObjPtr(Me) Then
If m_Object Is Nothing Then
KillTimer hWnd, ObjPtr(Me)
If IsEmpty(m_Abort) Then m_Abort = 1&
Exit Do
ElseIf m_PropName <> vbNullString Then
If CallByName(m_Object, m_PropName, VbGet) = m_PropValue Then
KillTimer hWnd, ObjPtr(Me)
If IsEmpty(m_Abort) Then m_Abort = 1&
Exit Do
End If
End If
End If
End If
If AllowReEntry = reEntry_None Then
bEat = Not (myMsg.hWnd = WM_TIMER)
ElseIf AllowReEntry = reEntry_NoChildren Then
If myMsg.hWnd = hWnd Then
bEat = False
Else
Select Case myMsg.message
Case WM_PAINT, WM_PRINT, WM_PRINTCLIENT, WM_TIMER
bEat = False
Case Else
bEat = True
End Select
End If
End If
If bEat Then
If Not m_hWndActive Is Nothing Then
bEat = Not (m_hWndActive.Item(CStr(myMsg.hWnd)) = 0&)
If Err Then Err.Clear
End If
End If
If bEat = False Then
TranslateMessage myMsg
DispatchMessage myMsg
If Err Then Err.Clear
End If
Loop
End Sub- reEntry_NoChildren. No controls will be allowed to receive messages
- reEntry_None. Absolutely no messages will be allowed to be received by any window (some exceptions)
- reEntry_All. All messages are allowed to flow through
In the examples, we will use a form-level class. Our class above is named: cWaitOnAsync. We will also assume there is a command button or menu that offers option to exit modal loop.
Code:
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
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
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
' 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
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