SetTimerで同期オブジェクト

Module1.bas

Option Explicit

Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As LongPtr
        bInheritHandle As Long
End Type
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
Const QS_ALLINPUT = &HFF
Const INFINITE = &HFFFFFFFF
Const WAIT_OBJECT_0 = &H0&
Private Declare Function CloseHandle Lib "kernel32" _
        (ByVal hObject As Long) As Long
Private Declare PtrSafe Function CreateEvent Lib "kernel32" Alias "CreateEventA" (lpEventAttributes As SECURITY_ATTRIBUTES, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As LongPtr
Private Declare PtrSafe Function SetEvent Lib "kernel32" (ByVal hEvent As LongPtr) As Long
Private Declare Function SetTimer Lib "user32" _
        (ByVal hWnd As Long, ByVal nIDEvent As Long, _
        ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" _
        (ByVal hWnd As Long, ByVal uIDEvent As Long) As Long

Private hEvent As LongPtr

Sub main()

    Dim st As SECURITY_ATTRIBUTES
    hEvent = CreateEvent(st, 0, 0, vbNullString)
    If hEvent = 0 Then Exit Sub
    SetTimer 0, 0, 0, AddressOf TimerProc

    Do While MsgWaitForMultipleObjects(1, hEvent, 0, _
                    INFINITE, QS_ALLINPUT) = WAIT_OBJECT_0 + 1
        DoEvents
    Loop
    CloseHandle hEvent
    Debug.Print "呼び出し元"
    
End Sub


Private Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, _
                      ByVal idEvent As Long, ByVal dwTime As Long)

    KillTimer 0, idEvent
    Debug.Print "TimerProc"
    SetEvent hEvent

End Sub