窗体:
Private mobjWaitTimer As clsWaitableTimer
Dim mbWorkToDo As Boolean
Dim mbStop As Boolean
Private Sub RunProcess()
Set mobjWaitTimer = New clsWaitableTimer
Do
If mbWorkToDo Then
'Call ProcessWork
Else
mobjWaitTimer.Wait (5000) ' 延时5秒 自行更改
End If
Loop Until Not mbStop
Set mobjWaitTimer = Nothing
End Sub
Private Sub Command1_Click()
RunProcess
Print "有没有延时成功呢？"
RunProcess
Print "应该有吧"
End Sub
Dim mbWorkToDo As Boolean
Dim mbStop As Boolean
Private Sub RunProcess()
Set mobjWaitTimer = New clsWaitableTimer
Do
If mbWorkToDo Then
'Call ProcessWork
Else
mobjWaitTimer.Wait (5000) ' 延时5秒 自行更改
End If
Loop Until Not mbStop
Set mobjWaitTimer = Nothing
End Sub
Private Sub Command1_Click()
RunProcess
Print "有没有延时成功呢？"
RunProcess
Print "应该有吧"
End Sub
类模块:
Option ExplicitPrivate Type FILETIMEdwLowDateTime As LongdwHighDateTime As LongEnd TypePrivate 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& = 0Private Const WAIT_OBJECT_1& = 1Private Const WAIT_TIMEOUT& = &H102&Private Const INFINITE = &HFFFFPrivate Const ERROR_ALREADY_EXISTS = 183&Private Const QS_HOTKEY& = &H80Private Const QS_KEY& = &H1Private Const QS_MOUSEBUTTON& = &H4Private Const QS_MOUSEMOVE& = &H2Private Const QS_PAINT& = &H20Private Const QS_POSTMESSAGE& = &H8Private Const QS_SENDMESSAGE& = &H40Private Const QS_TIMER& = &H10Private 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 LongPrivate Declare Function OpenWaitableTimer _Lib "kernel32" _Alias "OpenWaitableTimerA" (ByVal dwDesiredAccess As Long,_ByVal bInheritHandle As Long,_ByVal lpName As String) As LongPrivate Declare Function SetWaitableTimer _Lib "kernel32" (ByVal hTimer As Long,_lpDueTime As FILETIME,_ByVal lPeriod As Long,_ByVal pfnCompletionRoutine As Long,_ByVal lpArgToCompletionRoutineAs Long,_ByVal fResume As Long) As LongPrivate Declare Function CancelWaitableTimer Lib "kernel32" (ByVal hTimer As Long)Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongPrivate Declare Function WaitForSingleObject _Lib "kernel32" (ByVal hHandle As Long,_ByVal dwMilliseconds As Long) As LongPrivate 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 LongPrivate mlTimer As LongPrivate Sub Class_Terminate()On Error Resume NextIf mlTimer <> 0 Then CloseHandle mlTimerEnd SubPublic Sub Wait(MilliSeconds As Long)On Error GoTo ErrHandlerDim ft As FILETIMEDim lBusy As LongDim lRet As LongDim dblDelay As DoubleDim dblDelayLow As DoublemlTimer = CreateWaitableTimer(0,True,App.EXEName & "Timer" & Format$(Now(),"NNSS"))If Err.LastDllError <> ERROR_ALREADY_EXISTS Thenft.dwLowDateTime = -1ft.dwHighDateTime = -1lRet = SetWaitableTimer(mlTimer,ft,0)End IfdblDelay = CDbl(MilliSeconds) * 10000#ft.dwHighDateTime = -CLng(dblDelay / UNITS) - 1dblDelayLow = -UNITS * (dblDelay / UNITS - Fix(CStr(dblDelay / UNITS)))If dblDelayLow < MAX_LONG Then dblDelayLow = UNITS + dblDelayLowft.dwLowDateTime = CLng(dblDelayLow)lRet = SetWaitableTimer(mlTimer,False)DolBusy = MsgWaitForMultipleObjects(1,mlTimer,False,INFINITE,QS_ALLINPUT&)DoEventsLoop Until lBusy = WAIT_OBJECT_0CloseHandle mlTimermlTimer = 0Exit SubErrHandler:Err.Raise Err.Number,Err.Source,"[clsWaitableTimer.Wait]" & Err.DescriptionEnd Sub
原文链接：https://www.f2er.com/vb/261151.html