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 should be used only on Win95, it doesn't actualy freeze the routine and leave the process free to update but rather freeze the process for small 10 milliseconds intervals and then check for any new window messages (DoEvents). Win98/WinNT4 and above support waitable timers. The method with waitable timers is better than simply using Sleep api and DoEvents because it will waste less cpu time and will not lag the window message processing. For example, the simple method will loop 100 times each second but the waitable timer method will hung the application until the timer fires or any window message is received, it basicly trows the ball to the windows kernel. The lag and cpu time waste 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.

 Declare Function GetTickCount Lib "kernel32" () As Long
 
 Declare Function CreateWaitableTimer Lib "kernel32.dll" Alias "CreateWaitableTimerA" (ByRef lpTimerAttributes As Any, ByVal bManualReset As Long, ByVal lpTimerName As String) As Long
 Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
 Declare Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef lpDueTime As Any, ByVal lPeriod As Long, ByVal pfnCompletionRoutine As Long, lpArgToCompletionRoutine As Any, ByVal fResume As Long) As Long
 
 Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) 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 INFINITE As Long = &HFFFFFFFF
 
 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_HOTKEY As Long = &H80
 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

 Function Sleep(ByVal dwMilliseconds As Long) As Boolean
   Dim hTimer As Long, AUxBUFFER(0 To 1) As Long, StartTime As Long, AUxMSG As MSG
   hTimer = CreateWaitableTimer(ByVal 0, 0, vbNullString)
   If Not (CBool(hTimer)) Then Exit Function
   
   StartTime = GetTickCount
 Wait_LBL:
   AUxBUFFER(0) = dwMilliseconds
   If Not (CBool(SetWaitableTimer(hTimer, AUxBUFFER(0), 0, 0, ByVal 0, 0))) Then GoTo End_LBL
   
   If Not (MsgWaitForMultipleObjects(1, hTimer, True, INFINITE, QS_ALLEVENTS) = WAIT_OBJECT_0) Then GoTo End_LBL
   
   Do While CBool(PeekMessage(AUxMSG, 0, 0, 0, PM_REMOVE))
     TranslateMessage AUxMSG
     DispatchMessage AUxMSG
   Loop
   
   If WaitForSingleObject(hTimer, 0) = WAIT_TIMEOUT Then
     AUxBUFFER(0) = GetTickCount
     dwMilliseconds = dwMilliseconds - AUxBUFFER(0) + StartTime
     StartTime = AUxBUFFER(0)
     If dwMilliseconds >= 0 Then GoTo Wait_LBL
   End If
   
   Sleep = True
 End_LBL:
   CloseHandle hTimer
 End Function