爱尚共享网

VB6不会失去响应的延时处理模块

爱尚共享网2020-07-25学习资料 126 0A+A-

经常用到延时处理,常规方法非常占用CPU资源。本模块参考了某个类模块,那个类模块里的代码我理解得不透彻,就精简了一下写了本模块,没想到也能用,暂时没发现问题。

Option Explicit
 
 
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
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 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 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 Const WAIT_OBJECT_0 = 0
Private Const INFINITE = &HFFFF    '无限超时(Infinite timeout)
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)
 
Public Sub Yanshi(MilliSeconds As Long)
    On Error GoTo Cuo:
Dim Htimer As Long, WenjianTime As FILETIME, ret As Long
    'Htimer是计时器句柄
 
    If Htimer <> 0 Then CloseHandle Htimer
    Htimer = CreateWaitableTimer(0, True, "Timer" & Format(Now, "hhmmnn"))
    'CreateWaitableTimer创建一个可等待的计时器对象,返回值:Long,如执行成功,返回可等待
    '计时器对象的句柄;零表示出错。参数lpSemaphoreAttributes As SECURITY_ATTRIBUTES
    '指定一个结构,用于设置对象的安全特性。如将参数声明为ByVal As Long,并传递零值,
    '就可使用对象的默认安全设置。bManualReset As Long,如果为TRUE,表示创建一个人工重设计时器;
    '如果为FALSE,则创建一个自动重设计时器。lpName As String,指定可等待计时器对象的名称。
    If Htimer = 0 Then
        Debug.Print "调用CreateWaitableTimer失败"
        Exit Sub
    End If
    WenjianTime.dwHighDateTime = -1
    WenjianTime.dwLowDateTime = -(MilliSeconds * 10000)
    ret = SetWaitableTimer(Htimer, WenjianTime, 0, 0, 0, 0)
    'SetWaitableTimer启动一个可等待计时器,将它设为未发信号状态。返回值 As Long,非零表示成功,
    '零表示失败。hTimer As Long,指定一个可等待计时器的句柄。lpDueTime As FILETIME,指定
    '一个包含了64位时间值的结构。如果为正,它代表计时器要触发的时间。如果为负,它代表自
    '函数调用以来持续的时间。时间是以100ns为单位指定的。lPeriod As Long,如果为零,这个计时器
    '只会触发一次。否则,计时器会根据这里设置的持续时间自动重新启动(以毫秒为单位指定)。
    'pfnCompletionRoutine As Long,指定零或者计时器触发时要调用的一个函数的地址。可在标准
    '模块中用一个函数通过AddressOf操作符提供这个地址。或者使用此类ocx控件。最终的例程采取下述形式:
    'Sub myfunc(ByVal lpArgToCompletion&, ByVal dwTimerLow&, ByVal dwTimerHigh&)
    'lpArgToCompletionRoutine As Long,传递给最终例程的值。fResume As Long,如果为TRUE,
    '而且系统支持电源管理,那么在计时器触发的时候,系统会退出省电模式。如设为TRUE,但系统不
    '支持省电模式,GetLastError就会返回ERROR_NOT_SUPPORTED。
    '至于WenjianTime的dwHighDateTime和dwLowDateTime,dwHighDateTime设为-1,
    'dwLowDateTime设为-(延时时间*10000),因为要转换单位,所以要*10000。至于为什么是负的,
    '请看此句:如果为正,它代表计时器要触发的时间。如果为负,它代表自函数调用以来持续的时间。
    '时间是以100ns为单位指定的。后面4个参数都填0。
    If ret = 0 Then
        Debug.Print "调用SetWaitableTimer失败"
        CloseHandle Htimer
        Exit Sub
    End If
    Do
        ret = MsgWaitForMultipleObjects(1, Htimer, False, INFINITE, QS_ALLINPUT)
        '等候计时器发出信号
        DoEvents
    Loop Until ret = WAIT_OBJECT_0
    'MsgWaitForMultipleObjects等候单个对象或一系列对象发出信号,标志着规定的超时已经过去,
    '或特定类型的消息已抵达线程的输入队列。如返回条件已经满足,则立即返回。返回WAIT_OBJECT_0
    '意思是所有的对象都发出信号。参数:nCount,指定列表中的句柄数量。pHandles,指定对象句柄
    '组合中的第一个元素。fWaitAll,如果为TRUE,表示除非对象同时发出信号,否则就等待下去。
    '如果为FALSE,表示任何对象发出信号即可。dwMilliseconds,指定要等待的毫秒数,填INFINITE
    '表示无限等待。dwWakeMask,带有QS_??前缀的一个或多个常数,用于标识特定的消息类型。
    '如果用WaitForSingleObject函数就会导致窗口失去响应,所以本例用MsgWaitForMultipleObjects函数。
    '一旦不再需要,一定记住用CloseHandle关闭计时器对象的句柄。它的所有句柄都关闭以后,
    '对象自己也会删除。
    CloseHandle Htimer
    Htimer = 0
 
    Exit Sub
Cuo:
    CloseHandle Htimer
 
End Sub


发表评论