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