VB6 Sleep Function

[Derkel]

The sleep function for my VB6 doesn't work, it just freezes up the application. Can anyone give me a sleep function that won't freeze up the application?

[LaVolpe]

How about the API?
In your delcarations section add this

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

To use it

 Sleep 1000 ' to sleep for 1 second

[Derkel]

How about the API?
In your delcarations section add this

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

To use it

 Sleep 1000 ' to sleep for 1 second

Yeah, I was talking about that code, the only problem I have after that is that it doesn't seem to want to do all the codes after that sleep function

[LaVolpe]

Then something else is happening. Sleep only pauses your code then the next lines continue on. You may want to be more specific and post some relevant code that we can look at.

[CDRIVE]

The sleep function for my VB6 doesn't work, it just freezes up the application. Can anyone give me a sleep function that won't freeze up the application?

That's because the Sleep API freezes all events and the next line of code in your app until the Sleep period has expired. By it self I find it nearly useless. My favorite sub incorporates the Sleep API (in 2mS increments) and some additional code to create the Pause sub. Just use Pause (Sec or fraction of a second) where you would use Sleep.

Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

' Credits: (Milk (Sleep+Pause Sub)). (Wayne Spangler (Pause Sub))
Private Sub Pause(ByVal Delay As Single)
   Delay = Timer + Delay
   If Delay > 86400 Then 'more than number of seconds in a day
      Delay = Delay - 86400
      Do
          DoEvents ' to process events.
          Sleep 1 ' to not eat cpu
      Loop Until Timer < 1
   End If
   Do
       DoEvents ' to process events.
       Sleep 1 ' to not eat cpu
   Loop While Delay > Timer
End Sub

[anhn]

CDRIVE, That looks good to overcome the situation when pass midnight, however that has some minor problems:

1. As Timer() never reaches 86400, if Delay = 86400 (rare) then only the second Do...Loop runs 1 round: approx only 1 millisecond delay.
   So, instead of If Delay > 86400 Then , that should be If Delay >= 86400 Then
   
2. Delay may be greater than multiple of 86400, such as Delay = 259210 (=3*86400+10), then after Delay = Delay - 86400 you still have Delay > 86400.

Below is my Pause() function, it uses only one Do...Loop.
As Timer() is only updated every 1/64 sec = 15.625 millisecs, you can give the loop sleep a bit longer before checking Timer() vs TimeOut.
If higher-resolution timing is required then Timer() is not good enough, perhaps we have to use something else such as QueryPerformanceCounter()

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Sub Pause(SecsDelay As Single)
   Dim TimeOut   As Single
   Dim PrevTimer As Single
   
   PrevTimer = Timer
   TimeOut = PrevTimer + SecsDelay
   Do While PrevTimer < TimeOut
      Sleep 4 '-- Timer is only updated every 1/64 sec = 15.625 millisecs.
      DoEvents
      If Timer < PrevTimer Then TimeOut = TimeOut - 86400 '-- pass midnight
      PrevTimer = Timer
   Loop
End Sub

[CDRIVE]

Then something else is happening. Sleep only pauses your code then the next lines continue on. You may want to be more specific and post some relevant code that we can look at.

Ah, I thought the TS was referring to what's happening, or not happing, in other events during the Sleep interval.

[CDRIVE]

CDRIVE, That looks good to overcome the situation when pass midnight, however that has some minor problems:
[LIST=1][*]As Timer() never reaches 86400, if Delay = 86400 (rare) then only the second Do...Loop runs 1 round: approx only 1 millisecond delay.

Anhn, thanks for pointing that out. Even though I can't imagine a delay >86400 it's still worth mentioning.

[Urba1952]

Many thanks to LaVolpe for this posting of a sleep function. I needed a way to add a pause to a standard code module and the API call is exactly what the doctor ordered.

[georgekar]

The problem with DoEvents is that cause the Vb5/6 runtime to run any other event. Vb6 have re-entrance in event subroutine, so a pause in any of these subroutines or subroutines in a "bas" module, that we call from event subroutines, can't guarantee that a pause has a meaning of a pause.
So we have to break the re-entrance. I use a static variable once:
Sub That_Event()
static once as boolean
if once then exit sub
once=true
' our code here
once=false
exit sub

We can use a public "donothing" as boolean, so if it is true no event subroutine can do anything...until our pause end.

[Elroy]

Deleted

[TysonLPrice]

Just playing around and saw all the answers. Just throwing this out:

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Sub Command1_Click()
    Dim iTestIt As Integer
    iTestIt = 1
    Dim i As Integer
    
    For i = 1 To 10
        Text1.Text = iTestIt
        Text1.Refresh
        Sleep 1000
        iTestIt = iTestIt + 1
    Next i

End Sub

[baka]

the vb.timer is quite nice, as it will not freeze the form.
it all depends what u need it for and what kind of state u want the form to have while "processing" whatever you are doing.

before working with game-loops, i used the vb.timer.
its easy to make the timer do "operations", recursively, example:

Dim operation as integer
Dim funpr1 as integer

Private Sub doOperation(ByVal Op&)
    ' something '
End Sub

Private Sub function1()
    funpr1 = funpr1 + 1
    doOperation funpr1
    If funpr1 = 10 Then operation = 0
End Sub

Private Sub Timer1_Timer()
    Select Case operation
        Case 0: ' nothing '
        Case 1: function1
        Case 2: function2
        Case 3: function3
    End Select
End Sub

using sleep it will freeze the form and the functions, halting your program.
better to avoid using sleep if possible.

[dee-u]

This thread has been started more than a decade ago!

[Shaggy Hiker]

It started, went dormant for six years, revived for a brief time, went dormant for another five years....see y'all back here again around 2024 or 2025.

[TysonLPrice]

This thread has been started more than a decade ago!

Did you not see the post title...it obviously worked

[wqweto]

It started, went dormant for six years, revived for a brief time, went dormant for another five years....see y'all back here again around 2024 or 2025.

Someone has to reduce the value they are passing to the Sleep API in this thread to resemble a form of sane communication :-))

cheers,
</wqw>

[Shaggy Hiker]

Yeah, that may be it.

[q_97]

...see y'all back here again around 2024 or 2025.

You're not going to believe this...but I was just looking for how to do this. I had completely forgotten how I added pauses to VB6 code.

[xiaoyao]

Accuracy 100 nanoseconds, accurate to 0.0001 millisecond

Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long '???????

 Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long
 Declare Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As Long) As Long
 Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long
 Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
 Public Const INFINITE As Long = -1&, QS_ALLINPUT As Long = &H4FF&

Sub Puase(ByVal Milliseconds As Currency)
    Dim hTimer As Long
    hTimer = CreateWaitableTimerW
    Call SetWaitableTimer(hTimer, CCur(-Milliseconds))
    Do While MsgWaitForMultipleObjects(1&, hTimer, 0&, INFINITE, QS_ALLINPUT)
        DoEvents
    Loop
     CloseHandle hTimer
End Sub

Private Sub Form_Load()
 
timeBeginPeriod 1

End Sub

Private Sub Command1_Click()

Puase 1000

End Sub

[xiaoyao]

while(true)

             {
#029         if (WaitForSingleObject(hTimer, INFINITE) != WAIT_OBJECT_0)
#030         {
#031               OutputDebugString(_T("ERR"));   
#032               //
#033               CloseHandle(hTimer);
#034               return 3;
#035         }
#036         else
#037         {
#038              

                        SetWaitableTimer(hTimer, &liDueTime, 0, NULL, NULL, 0);//Reset the hTimer message to no signal, otherwise the output will continue
#039               OutputDebugString(_T("timer events"));            
#040         } 
#041    }
#042         //
#043         CloseHandle(hTimer);
#044         return 0;

how to do timer event without SetWaitableTimer(hTimer, &liDueTime, 0, NULL, NULL, 0);?

like

Ret = SetWaitableTimer(hTimer, CCur(-0.0001),-10000)
dim id as long

       Do
            ' Wait for timer signal or input message
            Select Case MsgWaitForMultipleObjects(1, hTimer, False, INFINITE, QS_ALLINPUT)
                
                Case WAIT_OBJECT_0:
                      Debug.Print "time event"
                      id=id+1
                      if id>100 then exit do
                Case WAIT_OBJECT_0 + 1:
                    
                    DoEvents
            End Select
 
        Loop

I want the third parameter to specify that an event is generated every 100 nanoseconds, or that a timer event is repeated every 1 second
But there's something wrong with this code

[xiaoyao]

Will produce a timer error accumulation, 10 times delay of 1 second, the final error reached about 6 milliseconds
Cumulative time: 10005.4726 ms
1, time: 999.5706 milliseconds
2, time: 1001.004 milliseconds
3, time: 999.9972 milliseconds
4, time: 1000.9968 milliseconds
5, time: 1001.0024 milliseconds
6, time: 1000.0044 milliseconds
7, time: 1000.0083 milliseconds
8, time: 1000.9891 milliseconds
9, time: 1000.9963 milliseconds
10, time: 1000.9035 milliseconds

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Const WAIT_ABANDONED& = &H80&
Private Const WAIT_ABANDONED_0& = &H80&
Private Const WAIT_FAILED& = -1&
Private Const WAIT_IO_COMPLETION& = &HC0&
Private Const WAIT_OBJECT_0& = 0
Private Const WAIT_OBJECT_1& = 1
Private Const WAIT_TIMEOUT& = &H102&
Private Const INFINITE = &HFFFF
Private Const QS_HOTKEY& = &H80
Private Const QS_KEY& = &H1
Private Const QS_MOUSEBUTTON& = &H4
Private Const QS_MOUSEMOVE& = &H2
Private Const QS_PAINT& = &H20
Private Const QS_POSTMESSAGE& = &H8
Private Const QS_SENDMESSAGE& = &H40
Private Const QS_TIMER& = &H10
Private Const ERROR_ALREADY_EXISTS = 183&
Private Const QS_MOUSE& = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Private Const QS_INPUT& = (QS_MOUSE Or QS_KEY)
Private Const QS_ALLEVENTS& = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)
Private 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)

Private Const UNITS = 4294967296#
Private Const MAX_LONG = -2147483648#

Private Declare Function CreateWaitableTimer _
                Lib "kernel32" _
                Alias "CreateWaitableTimerA" (ByVal lpSemaphoreAttributes As Long, _
                                              ByVal bManualReset As Long, _
                                              ByVal lpName As String) As Long
Private Declare Function OpenWaitableTimer _
                Lib "kernel32" _
                Alias "OpenWaitableTimerA" (ByVal dwDesiredAccess As Long, _
                                            ByVal bInheritHandle As Long, _
                                            ByVal lpName As String) As Long
Private Declare Function SetWaitableTimer _
                Lib "kernel32" (ByVal hTimer As Long, _
                                lpDueTime As FILETIME, _
                                ByVal lPeriod As Long, _
                                ByVal pfnCompletionRoutine As Long, _
                                ByVal lpArgToCompletionRoutine As Long, _
                                ByVal fResume As Long) As Long
Private Declare Function CancelWaitableTimer Lib "kernel32" (ByVal hTimer As Long)
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject _
                Lib "kernel32" (ByVal hHandle As Long, _
                                ByVal dwMilliseconds As Long) As Long
Private 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

Private mlTimer As Long
Sub StartTimer4()
    Randomize
    mlTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer" & Format$(Now(), "NNSS") & Int(Rnd * 10000))
     If Err.LastDllError = ERROR_ALREADY_EXISTS Then
     MsgBox "TIMER ERR"
     End If
End Sub
Sub CloseTimer4()

    On Error Resume Next

    If mlTimer <> 0 Then CloseHandle mlTimer
End Sub

Public Sub WaitCounts(MilliSeconds As Currency, Counts As Long)
    On Error GoTo ErrHandler
    Dim ft          As FILETIME
    Dim lBusy       As Long
    Dim lRet        As Long
    Dim dblDelay    As Double
    Dim dblDelayLow As Double
    

    
 
        ft.dwLowDateTime = -1
        ft.dwHighDateTime = -1
        lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, 0)
 
    'CDbl
    dblDelay = CCur(MilliSeconds) * 10000#
    
    ft.dwHighDateTime = -CLng(dblDelay / UNITS) - 1
    dblDelayLow = -UNITS * (dblDelay / UNITS - Fix(CStr(dblDelay / UNITS)))
    
    If dblDelayLow < MAX_LONG Then dblDelayLow = UNITS + dblDelayLow
    
    ft.dwLowDateTime = CLng(dblDelayLow)
    Dim ID As Long
    Dim UsedC() As Currency, StartC As Currency
    ReDim UsedC(0 To Counts)
    QueryPerformanceCounter CPUv1
    StartC = CPUv1
    lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, False)
    
    Do While True
        lBusy = MsgWaitForMultipleObjects(1, mlTimer, False, INFINITE, QS_ALLINPUT&)
        If lBusy = WAIT_OBJECT_0 Then
            ID = ID + 1
              QueryPerformanceCounter CPUv2
           
             UsedC(ID) = CPUv2 
            If ID = Counts Then Exit Do
             'QueryPerformanceCounter CPUv1
             CPUv1 = CPUv2
            SetWaitableTimer mlTimer, ft, 0, 0, 0, False
        Else
        DoEvents
        End If
      
    Loop
    
'    CloseHandle mlTimer
'    mlTimer = 0
Dim i As Long
UsedC(0) = StartC

Debug.Print "All UsedTime?" & (CPUv2 - StartC) / MsCount & "ms"
For i = 1 To 10
    Debug.Print i & ",Used?" & (UsedC(i) - UsedC(i - 1)) / MsCount & "ms"
Next
    Exit Sub
    
ErrHandler:
    Err.Raise Err.Number, Err.Source, "[clsWaitableTimer.Wait]" & Err.Description
End Sub

Private Sub Form_Load()
timeBeginPeriod 1
 

StartTimer4
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
CloseTimer4
End Sub

[xiaoyao]

The timer interval is 1 second, each time the timer is triggered, modify the delay milliseconds, correct the error (such as delay 995 milliseconds, delay 1002 milliseconds), the final 100 times, 1000 times of the timer triggered, (unlimited number of runs) the cumulative error is only about 1 millisecond.

All UsedTime?20000.0194ms
1,Used?2000.0174ms
2,Used?2000.0064ms
3,Used?2001.0059ms
4,Used?1998.9939ms
5,Used?2000.9611ms
6,Used?1999.9619ms
7,Used?1999.0738ms
8,Used?2000.0403ms
9,Used?1999.9592ms
10,Used?1999.9995ms

Public Sub WaitCounts(MilliSeconds As Currency, Counts As Long)
    On Error GoTo ErrHandler
    Dim ft          As FILETIME
    Dim lBusy       As Long
    Dim lRet        As Long
    Dim dblDelay    As Double
    Dim dblDelayLow As Double
    

    
 
        ft.dwLowDateTime = -1
        ft.dwHighDateTime = -1
        lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, 0)
 
    'CDbl
    dblDelay = CCur(MilliSeconds) * 10000#
    ft.dwHighDateTime = -CLng(dblDelay / UNITS) - 1
    dblDelayLow = -UNITS * (dblDelay / UNITS - Fix(CStr(dblDelay / UNITS)))
    If dblDelayLow < MAX_LONG Then dblDelayLow = UNITS + dblDelayLow
    ft.dwLowDateTime = CLng(dblDelayLow)
    
    Dim ID As Long
    Dim UsedC() As Currency, StartC As Currency
    ReDim UsedC(0 To Counts)
    QueryPerformanceCounter CPUv1
    StartC = CPUv1
    UsedC(0) = StartC
    lRet = SetWaitableTimer(mlTimer, ft, 0, 0, 0, False)
    
    Do While True
        lBusy = MsgWaitForMultipleObjects(1, mlTimer, False, INFINITE, QS_ALLINPUT&)
        If lBusy = WAIT_OBJECT_0 Then
              ID = ID + 1
              QueryPerformanceCounter CPUv2
             'Debug.Print ID & ",???" & (CPUv2 - CPUv1) / MsCount & "??"
             UsedC(ID) = CPUv2
            If ID = Counts Then Exit Do
             'CPUv1 = CPUv2
             '==========================
             QueryPerformanceCounter CPUv1
             Dim MilliSeconds2 As Currency
             MilliSeconds2 = (ID + 1) * MilliSeconds - (CPUv1 - StartC) / MsCount
             dblDelay = CCur(MilliSeconds2) * 10000#
             ft.dwHighDateTime = -CLng(dblDelay / UNITS) - 1
             dblDelayLow = -UNITS * (dblDelay / UNITS - Fix(CStr(dblDelay / UNITS)))
             If dblDelayLow < MAX_LONG Then dblDelayLow = UNITS + dblDelayLow
             ft.dwLowDateTime = CLng(dblDelayLow)
    '===================
            SetWaitableTimer mlTimer, ft, 0, 0, 0, False
        Else
        DoEvents
        End If
      
    Loop
    
'    CloseHandle mlTimer
'    mlTimer = 0
Dim i As Long
UsedC(0) = StartC
Debug.Print "All UsedTime?" & (CPUv2 - StartC) / MsCount & "ms"
For i = 1 To 10
    Debug.Print i & ",Used?" & (UsedC(i) - UsedC(i - 1)) / MsCount & "ms"
Next
    Exit Sub
    
ErrHandler:
    Err.Raise Err.Number, Err.Source, "[clsWaitableTimer.Wait]" & Err.Description
End Sub

[wqweto]

Why so much API, why so much complexity for something as trivial as waiting for a few seconds and the result is some mind-bending code. . .

cheers,
</wqw>

[xiaoyao]

SetWaitableTimer?The precision of this API is about one millisecond. If we want to delay 2 second, we set a delay of 1998 milliseconds.
How many milliseconds are left to calculate, and then use an endless loop to execute it.
Equivalent to sleep 1.023ms,You can then get a 100% accurate delay function. The error may be only one microsecond.

In order to improve the accuracy of the timer, a number of apis are used. In fact, this is only used in accurately controlling the frame rate of the game, and the upper computer of the factory machine is accurate to send instructions, and it is not used with such high precision.

[Niya]

....see y'all back here again around 2024 or 2025.

So you're not only a programmer, you're also a prophet

[Shaggy Hiker]

This is a situation where LOL is literally true. I am utterly amazed at the timing of this resurrection.

[xiaoyao]

Unless our forum has an automatic search function before each new post.
If the correct answer to your question can be found on the first page of search results, no one will post it.

Can the forum dock with ai to answer programming questions automatically?
If we can't find the answer we need in our search results, we will reply automatically. If I think this list is useful, I can click on it to post. Automatically turn the reply made by the robot into a question and answer.

[q_97]

Glad I could provide some amusement.

Found this post through DDG, as I've been a bit nostalgic for some earlier projects I worked on. Hopefully I can dig up the source code in a couple of months when I visit my family. I wonder if I can understand any of it if I do, as I seem to remember not understanding how some of it worked at the time. I seem to remember writing lots of comments, but I'm not sure that's going to help.