Sleep without locking

This article is based on Visual Basic 6. Find other Visual Basic 6 articles.

It is common in programming to need to have a timer of some form that will freeze your routine for a specified amount of time. One way to do this is to use the Sleep() API. Unfortunately there is a downside to this method, and that is that it will freeze your process. Not only does this mean that your APP's GUI updates will not occur until AFTER Sleep() returns, but also that your app will appear frozen to task manager.

So what's the solution? Why, create your own Sleep() function of course!

 Private Declare Function GetTickCount& Lib "kernel32" ()
 Private Declare Sub APISleep Lib "kernel32.dll" Alias "Sleep" (ByVal dwMilliseconds As Long)

 Private Sub Sleep(ByVal dwMilliseconds As Long)
     Dim initTickCount As Long
     
     initTickCount = GetTickCount
     Do Until GetTickCount - initTickCount >= dwMilliseconds
         APISleep 10
         'Use the API call for sleep to prevent 100% cpu usage
         DoEvents
     Loop
 End Sub

This will freeze the routine from which it was called for the specified time, but leave the process free to update the GUI.

Simple as that.

---

The above method is easier to implement but should not be used for two reasons: wastes cpu time for iterating that loop 100 times a second and lags the window message processing with 10 milliseconds. The lag and cpu time waste might seem a minor drawback but it's not! If you're using a window for heavy networking traffic or any other activity that implies tons of messages per second you will notice a small lag caused by the Sleep api. So... instead of waiting small intervals and checking for messages we'll wait for new messages using our initial interval. When a message appears in the msg queue MsgWaitForMultipleObjects will return, the message loop will take care or it and then it will go back to waiting only if it needs to. This method is better than the simple sleep/doevents one because it trows the ball to the kernel and doesn't resume unless it has to (new message or timer event).

Compatibility: Win95/WinNT4 and above

 Declare Function GetTickCount Lib "kernel32" () As Long
 
 Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, pHandles As Long, ByVal fWaitAll As Boolean, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long
 
 Global Const QS_MOUSEMOVE As Long = &H2
 Global Const QS_MOUSEBUTTON As Long = &H4
 Global Const QS_MOUSE As Long = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
 Global Const QS_KEY As Long = &H1
 Global Const QS_INPUT As Long = (QS_MOUSE Or QS_KEY)
 Global Const QS_POSTMESSAGE As Long = &H8
 Global Const QS_TIMER As Long = &H10
 Global Const QS_PAINT As Long = &H20
 Global Const QS_SENDMESSAGE As Long = &H40
 Global Const QS_HOTKEY As Long = &H80
 Global Const QS_ALLINPUT As Long = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)
 Global Const QS_ALLEVENTS As Long = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)
 
 Global Const STATUS_WAIT_0 As Long = &H0
 Global Const STATUS_ABANDONED_WAIT_0 As Long = &H80
 Global Const WAIT_TIMEOUT As Long = 258&
 Global Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0 + 0)
 Global Const WAIT_ABANDONED As Long = (STATUS_ABANDONED_WAIT_0 + 0)
 
 Type POINTAPI
   X As Long
   Y As Long
 End Type
 
 Type MSG
   hwnd    As Long
   message As Long
   wParam  As Long
   lParam  As Long
   time    As Long
   pt      As POINTAPI
 End Type
 
 Global Const PM_NOREMOVE As Long = &H0
 Global Const PM_REMOVE   As Long = &H1
 Global Const PM_NOYIELD  As Long = &H2
 
 Declare Function PeekMessage Lib "user32.dll" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
 Declare Function TranslateMessage Lib "user32.dll" (lpMsg As MSG) As Long
 Declare Function DispatchMessage Lib "user32.dll" Alias "DispatchMessageA" (lpMsg As MSG) As Long

 Sub Sleep(ByVal dwMilliseconds As Long)
   Dim StartTime As Long, AUxMSG As MSG, AUxLong As Long
   StartTime = GetTickCount
 Wait_LBL:
   AUxLong = MsgWaitForMultipleObjects(0, ByVal 0, False, dwMilliseconds, QS_ALLEVENTS)
   If AUxLong = WAIT_TIMEOUT Then Exit Sub
   Do While CBool(PeekMessage(AUxMSG, 0, 0, 0, PM_REMOVE))
     TranslateMessage AUxMSG
     DispatchMessage AUxMSG
   Loop
   AUxLong = GetTickCount
   dwMilliseconds = dwMilliseconds - AUxLong + StartTime
   If dwMilliseconds >= 0 Then
     StartTime = AUxLong
     GoTo Wait_LBL
   End If
 End Sub