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

[xiaoyao]

how to put objXMLHTTP.readyState=4 to replace IsDone ?

Function GetBody(weburl)
  dim objXMLHTTP
  set objXMLHTTP=Server.CreateObject("MSXML2.serverXMLHTTP")
  objXMLHTTP.Open "GET",weburl,false
  objXMLHTTP.send
  while objXMLHTTP.readyState<>4
    doevents
  wend
  GetBody=BytesToBstr(objXMLHTTP.responseBody,"GB2312")
  set objXMLHTTP=nothing
End Function

WaitCom objXMLHTTP,"readyState",4&

Sub WaitCom(Com As Object, ProcName As String, Value1)
    Do While Not CallByName(Com, ProcName, VbMethod) = Value
         DoEvents
    Loop
End Sub

[dilettante]

Use the events provided. Read the documentation. After that a search here should turn up plenty of examples.

[xiaoyao]

how to wait function address?

Dim id As Long
Function GetDoOK() As Boolean
    Debug.Print "call GetDoOK"
    GetDoOK = id > 2
End Function
Private Sub Command5_Click()
id = id + 1
Command5.Caption = "id=" & id
End Sub

Private Sub Command4_Click()
    id = 0
    Command1.Enabled = False
    DoOk = False
    T1 = timeGetTime

    Debug.Print WaitFunction(GetDoOK(), 4000)
    
    MsgBox "Used Time:" & timeGetTime - T1
    Command1.Enabled = True
End Sub

Function WaitFunctionValue(FunctionAddress As Long, TrueValue, Optional TimeOutMs As Long = 5000) As Boolean
      If SetWaitableTimer(JshTimer, CCur(-TimeOutMs)) Then   '原来的
           Do While MsgWaitForMultipleObjects(1&, JshTimer, FAL_SE, INFINITE, QS_ALLINPUT) And Not (FunctionAddress = TrueValue)
                DoEvents
          Loop
     End If
     WaitFunctionValue = IsDone
End Function
Function WaitFunction(FunctionAddress As Long, TrueValue, Optional TimeOutMs As Long = 5000) As Boolean
      If SetWaitableTimer(JshTimer, CCur(-TimeOutMs)) Then   '原来的
           Do While MsgWaitForMultipleObjects(1&, JshTimer, FAL_SE, INFINITE, QS_ALLINPUT) And Not FunctionAddress
                DoEvents
          Loop
     End If
     WaitFunction = IsDone
End Function