為ACCESS添加多個Timer功能

leijiqiang

這是好東西

leijiqiang

非常不錯,嗯~

elong

謝謝,分享

ztalex_ywt

學(xué)習(xí)

chenzhirong2008

太粗燥了. 給你定時器類.

'* ******************************************** *

'*  模塊名稱：Timer.cls

'*  功能：在VB類模塊中使用計時器

'* ******************************************** *



Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, _
    Source As Any, ByVal Length 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 nIDEvent As Long) As Long

Private m_Tag As String

Private m_TimerID As Long

Private m_Enabled As Boolean

Private m_Interval As Long

Private m_EventEnter As Boolean         '事件實例標識, 防止一個早期實例未結(jié)束之前開始另一個實例

Public Event ThatTime()

Private Sub Class_Initialize()

    m_Interval = 0

End Sub

Private Sub Class_Terminate()

    If m_TimerID <> 0 Then KillTimer 0, m_TimerID

End Sub

Public Property Get Interval() As Long

    Interval = m_Interval

End Property

Public Property Let Interval(ByVal New_Value As Long)
   
    If New_Value > 0 Then
        '如果事件間隔相同, 退出
        If m_Interval = New_Value Then Exit Property
        
        If m_Enabled Then
            '如果類為Enable, 創(chuàng)建一個新的定時器
            
            m_Interval = New_Value
            '先銷毀假設(shè)存在的舊定時器,再啟動新定時器
            If m_TimerID <> 0 Then KillTimer 0, m_TimerID
            m_TimerID = SetTimer(0, 0, m_Interval, GetFuncAddr(10))     '注意回調(diào)函數(shù)地址,TimerProc為第10個函數(shù)
        
        Else
        ' 定時器disable, 僅修改時間間隔
            m_Interval = New_Value
        End If
        
    Else
   
        '新的事件間隔小于等于0, 銷毀定時器
        m_Interval = 0
        If m_TimerID <> 0 Then KillTimer 0, m_TimerID
        m_TimerID = 0
        
    End If

End Property

Public Property Get Enabled() As Boolean

    Enabled = m_Enabled

End Property

Public Property Let Enabled(ByVal New_Value As Boolean)

    If New_Value = m_Enabled Then Exit Property
   
    If New_Value Then
   
        '新值允許定時器啟動
        m_Enabled = New_Value
        
        If m_TimerID <> 0 Then      '如果存在舊定時器, 先銷毀
            KillTimer 0, m_TimerID
            m_TimerID = 0
        End If
        
        '檢查時間間隔, 如果>0 則啟動新定時器
        If m_Interval > 0 Then
            m_TimerID = SetTimer(0, 0, m_Interval, GetFuncAddr(10))         '注意回調(diào)函數(shù)地址,TimerProc為第10個函數(shù)
        End If
        
    Else
   
        '新值設(shè)定時器disable,銷毀定時器
        m_Enabled = False
        If m_TimerID <> 0 Then KillTimer 0, m_TimerID
        m_TimerID = 0
        
    End If

End Property

Public Property Get Tag() As String

    Tag = m_Tag
End Property

Public Property Let Tag(New_Value As String)

    m_Tag = New_Value
End Property

Private Function GetFuncAddr(ByVal IndexOfFunc As Long) As Long
'IndexOfFunc -- 類中第幾個函數(shù)??
'是從某個類模塊中最頂端的函數(shù)或?qū)傩运闫?他是第幾個函數(shù)

'這個參數(shù)有講究...
'1. 當(dāng)被查找的函數(shù)為 公用函數(shù)時,它的值就是自頂端算起的第幾個函數(shù),比如你在類模塊中最頂端寫的一個公用函數(shù) WndProc,那么就傳 1
'     如果是第2個公用函數(shù)或?qū)傩阅敲淳蛡?2 依次...  注意,計算的時候要算上公用屬性,公用屬性也要算上,屬性相當(dāng)于函數(shù),算做一個
'
'2. 當(dāng)被查找的函數(shù)為 局部函數(shù)時,也就是說如果是 Private 修飾的函數(shù),則此參數(shù)值為 所有公用函數(shù)個數(shù) + 這是第 N 個私有函數(shù)
'     也是從頂端算起 , 同樣包括屬性

Static AsmCode(33) As Byte

Dim pThis As Long, pVtbl As Long, pFunc As Long
   

    pThis = ObjPtr(Me)

    CopyMemory pVtbl, ByVal pThis, 4

    CopyMemory pFunc, ByVal pVtbl + (6 + IndexOfFunc) * 4, 4

    AsmCode(0) = &H55

    AsmCode(1) = &H8B: AsmCode(2) = &HEC

    CopyMemory AsmCode(3), &H1475FF, 3

    CopyMemory AsmCode(6), &H1075FF, 3

    CopyMemory AsmCode(9), &HC75FF, 3

    CopyMemory AsmCode(12), &H875FF, 3

    AsmCode(15) = &HB9

    CopyMemory AsmCode(16), pThis, 4

    AsmCode(20) = &H51

    AsmCode(21) = &HE8

    CopyMemory AsmCode(22), pFunc - VarPtr(AsmCode(21)) - 5, 4

    AsmCode(26) = &H8B: AsmCode(27) = &HE5

    AsmCode(28) = &H5D

    AsmCode(29) = &HC2

    CopyMemory AsmCode(30), 16, 4

    GetFuncAddr = VarPtr(AsmCode(0))

End Function


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

    '如果這個事件的一個早期實例仍然在進行時，不要產(chǎn)生此事件。
    If m_EventEnter Then Exit Sub
   
    'm_EventEnter 標志將阻塞這個事件的未來實例直到當(dāng)前的事例完成。
    m_EventEnter = True
   
'    Debug.Print "raise event"
    ' Generate the event
    RaiseEvent ThatTime
   
    ' 允許這個事件再次進入 TimerProc。
    m_EventEnter = False

End Sub

wdq

c101

謝謝分享

like5188

ddddddd

qimingju

這個不錯哦，一定要頂頂

liaoqiang234

謝分享