Delay an Application Until a Specified Condition is True II

Category:

Miscellaneous

Type:

Modules

Difficulty:

Advanced

Author:

Jens Neuhalfen

Version Compatibility: Visual Basic 5

More information:

I just read "Delay an Application Until a Specified Condition is True" and found a problem: the DoEvents loop consumes lots of processor time because it's *polling* for messages/state changes. This is absolutely unperfomant and *not* threadsafe.

A better way is to use Win32API-Events.

A quick test of the while not bCancel:DoEvents:wend method showed 97% processor usage on WinNT 4.0 / 233Mhz! My method uses only "normal" processing time.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
Global Const EVENT_NOT_SET = vbObjectError + 512 + 1 Public Const INFINITE = &HFFFF ' Infinite timeout Public 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 Public Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (ByVal lpEventAttributes As Long, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As Long Public Declare Function PulseEvent Lib "kernel32" (ByVal hEvent As Long) As Long Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Public Declare Function SetEvent Lib "kernel32" (ByVal hEvent As Long) As Long Public Declare Function ResetEvent Lib "kernel32" (ByVal hEvent As Long) As Long Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Public Const QS_HOTKEY = &H80 Public Const QS_KEY = &H1 Public Const QS_MOUSEBUTTON = &H4 Public Const QS_MOUSEMOVE = &H2 Public Const QS_PAINT = &H20 Public Const QS_POSTMESSAGE = &H8 Public Const QS_SENDMESSAGE = &H40 Public Const QS_TIMER = &H10 Public Const QS_MOUSE = (QS_MOUSEMOVE Or QS_MOUSEBUTTON) Public Const QS_INPUT = (QS_MOUSE Or QS_KEY) Public 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) Public Const QS_ALLEVENTS = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY) Public Const WAIT_OBJECT_0 = 0 Public Const PM_NOREMOVE = &H0 Public Const PM_NOYIELD = &H2 Public Const WM_QUIT = &H12 Public Type POINTAPI x As Long y As Long End Type Public Type MSG hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type

Code:

Option explicit

Public Function VB_WaitFor(ByVal hCloseEvent  As long,ByVal maxTimeToWait As Long) as Boolean

'AUTHOR
' Jens Neuhalfen
' Akkaya Consulting GmbH
' JNeuhalfen@akkaya.de
'
' #####################################################################
'
'PURPOSE:  Wait until either
'          a condition is true or a timeout occurs
'          This function will work like a
'          "While bNotCancel:DoEvents:Wend"  loop but won't consume
'          that much time! The above loop consumes about 98% on my 233MMX.
'          this function won't use more that "normal" VB apps.
' #####################################################################
'
'PARAMETER
' hCloseEvent
'      You have to create the event at the start of your program using
'      hCloseEvent = CreateEvent(0&, -1&, 0&, vbNullString)
'             (unsignaled, manual reset)
'
' maxTimeToWait
'    The TimeOut value in milliseconds.
'    If you use INFINITE better make sure the event gets fired ... 
'
' #####################################################################
'
'RETURN: true on event, false on timeout
'
'USAGE
'  When you want to cancel the wait operation (VB_WaitFor = true) just call 
'  PulseEvent(hCloseEvent)
'
' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' DON'T forget to call CloseHandle(hCloseEvent) when you quit your app! 
' Windows doesn't like handles not to be released.
' It's always a wise choice to call PulseEvent(hCloseEvent) *before* you are
' about to quit your app (to destroy the artificial message loops).
' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'
' #####################################################################
'
       
     if ( 0 = hCloseEvent  ) then  Err.Raise  EVENT_NOT_SET
     Dim aMSG As MSG
     dim tmp as long
     Do
      tmp= MsgWaitForMultipleObjects(1, hCloseEvent, False, INFINITE, QS_ALLINPUT)  
      if (tmp <> WAIT_OBJECT_0) then
	      If PeekMessage(aMSG, 0&, WM_QUIT, WM_QUIT, PM_NOREMOVE Or PM_NOYIELD) Then
      		 If WM_QUIT = aMSG.message Then 
      		  'I'm honest not sure if you NEED to catch WM_QUIT (never got it ...)  but you never know ...
        	  PulseEvent hCloseEvent 'we are going to quit, better stop this loop!
                  VB_WaitFor = false
                  exit function
              End If
              DoEvents 'Dispatch messages
      End If
     Loop While tmp<> WAIT_OBJECT_0

'When we are here either a timeout occured or the event is set
 VB_WaitFor =  (tmp =  WAIT_OBJECT_0)
End Sub