Option
Explicit
Private
TypeFILETIME
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
ERROR_ALREADY_EXISTS=183&
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
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
Private
Sub
Class_Terminate()
On
Error
Resume
Next
If
mlTimer<>0
Then
CloseHandlemlTimer
End
Sub
Public
Sub
Wait(MilliSeconds
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
mlTimer=CreateWaitableTimer(0,
True
,App.EXEName&
"Timer"
&Format$(Now(),
"NNSS"
))
If
Err.LastDllError<>ERROR_ALREADY_EXISTS
Then
ft.dwLowDateTime=-1
ft.dwHighDateTime=-1
lRet=SetWaitableTimer(mlTimer,ft,0)
End
If
dblDelay=
CDbl
(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)
lRet=SetWaitableTimer(mlTimer,
False
)
Do
lBusy=MsgWaitForMultipleObjects(1,mlTimer,
False
,INFINITE,QS_ALLINPUT&)
DoEvents
Loop
Until
lBusy=WAIT_OBJECT_0
CloseHandlemlTimer
mlTimer=0
Exit
Sub
ErrHandler:
Err.RaiseErr.Number,Err.Source,
"[clsWaitableTimer.Wait]"
&Err.Description
End
Sub
'调用--------------------------------------------
Private
Sub
cmdWaitTimer_Click()
Dim
objTimer
As
clsWaitableTimer
Set
objTimer=
New
clsWaitableTimer
cmdWaitTimer.Enabled=
False
objTimer.Wait5000
cmdWaitTimer.Enabled=
True
Set
objTimer=
Nothing
End
Sub
