vb6 Await,pause,WaitSync,Delay function that does not occupy CPU

[xiaoyao]

vb6 pause,WaitSync,Delay function that does not occupy CPU

use for Game in vb6-VBForums
https://www.vbforums.com/showthread....31#post5609131

    
delay 1000 'Pause
WaitSync DoOk, 4000

form1.form

Dim DoOk As Boolean, T1 As Long
Private Sub Command1_Click()
    Command1.Enabled = False
    DoOk = False
    T1 = timeGetTime
    
    WaitSync DoOk, 4000
    
    MsgBox "Used Time:" & timeGetTime - T1
    Command1.Enabled = True
End Sub

Private Sub Command2_Click()
    DoOk = True
End Sub

Private Sub Form_Load()
NewTimer
End Sub

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

module1.bas

Option Explicit
Public Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Public Declare Function timeEndPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Public Declare Function timeGetTime Lib "winmm.dll" () As Long

Public Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Public Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long
Public 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
Public 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
Public JshTimer As Long
Public Const FAL_SE As Long = 0&, INFINITE As Long = -1&, QS_ALLINPUT As Long = &H4FF&, WAIT_OBJECT_0  As Long = &H0&

Sub NewTimer()
    If JshTimer = 0 Then
        timeBeginPeriod 1
        JshTimer = CreateWaitableTimerW                               'Create a one-shot waitable timer object
    End If
End Sub
Sub CloseTimer()
    timeEndPeriod 1
    If JshTimer <> 0 Then CloseHandle JshTimer: JshTimer = 0
 End Sub
 Sub Main()
   NewTimer
   
    Dim T1 As Long
    T1 = timeGetTime
    Pause 1300
    Debug.Print "Used Time :" & timeGetTime - T1 & " MS"
 End Sub
Sub Pause(ByVal Milliseconds As Currency) 'PauseWtimer
      If SetWaitableTimer(JshTimer, CCur(-Milliseconds)) Then   '原来的
          Do While MsgWaitForMultipleObjects(1&, JshTimer, FAL_SE, INFINITE, QS_ALLINPUT) '从1变成0就结束了
            DoEvents
          Loop
      End If
End Sub

Sub WaitSync(IsDone As Boolean, Optional TimeOutMs As Long = 5000)
'WaitVSync,WaitForTrue
      If SetWaitableTimer(JshTimer, CCur(-TimeOutMs)) Then   '原来的
           Do While MsgWaitForMultipleObjects(1&, JshTimer, FAL_SE, INFINITE, QS_ALLINPUT) And Not IsDone
                DoEvents
          Loop
     End If
End Sub