作者:lyserver
这名字好熟悉,感觉在csdn经常看到,应该是个老前辈
以下代码复制到一个 类模块 cTimer.cls
Option Explicit
'* ******************************************** *
'* 模块名称:clsTimer.cls
'* 功能:在VB类模块中使用计时器
'* 作者:lyserver
'* ******************************************** *
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
Dim m_idTimer As Long
Dim m_Enabled As Boolean
Dim m_Interval As Long
Dim m_lTimerProc As Long
Public Event Timer()
Private Sub Class_Initialize()
m_Interval = 0
m_lTimerProc = GetClassProcAddr(8)
'Debug.Print "GetClassProcAddr:" & m_lTimerProc; ""
End Sub
Private Sub Class_Terminate()
If m_idTimer <> 0 Then KillTimer 0, m_idTimer
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 m_Interval = New_Value
End Property
Public Property Get Enabled() As Boolean
Enabled = m_Enabled
End Property
Public Property Let Enabled(ByVal New_Value As Boolean)
m_Enabled = New_Value
If m_idTimer <> 0 Then KillTimer 0, m_idTimer
If New_Value And m_Interval > 0 Then
m_idTimer = SetTimer(0, 0, m_Interval, m_lTimerProc)
End If
End Property
Private Function GetClassProcAddr(ByVal Index As Long, _
Optional ParamCount As Long = 4, _
Optional HasReturnValue As Boolean) As Long
Static lReturn As Long, pReturn As Long
Static AsmCode(50) As Byte
Dim i As Long, pThis As Long, pVtbl As Long, pFunc As Long
pThis = ObjPtr(Me)
CopyMemory pVtbl, ByVal pThis, 4
CopyMemory pFunc, ByVal pVtbl + (6 + Index) * 4, 4
pReturn = VarPtr(lReturn)
For i = 0 To UBound(AsmCode)
AsmCode(i) = &H90
Next
AsmCode(0) = &H55
AsmCode(1) = &H8B: AsmCode(2) = &HEC
AsmCode(3) = &H53
AsmCode(4) = &H56
AsmCode(5) = &H57
If HasReturnValue Then
AsmCode(6) = &HB8
CopyMemory AsmCode(7), pReturn, 4
AsmCode(11) = &H50
End If
For i = 0 To ParamCount - 1
AsmCode(12 + i * 3) = &HFF
AsmCode(13 + i * 3) = &H75
AsmCode(14 + i * 3) = (ParamCount - i) * 4 + 4
Next
i = i * 3 + 12
AsmCode(i) = &HB9
CopyMemory AsmCode(i + 1), pThis, 4
AsmCode(i + 5) = &H51
AsmCode(i + 6) = &HE8
CopyMemory AsmCode(i + 7), pFunc - VarPtr(AsmCode(i + 6)) - 5, 4
If HasReturnValue Then
AsmCode(i + 11) = &HB8
CopyMemory AsmCode(i + 12), pReturn, 4
AsmCode(i + 16) = &H8B
AsmCode(i + 17) = &H0
End If
AsmCode(i + 18) = &H5F
AsmCode(i + 19) = &H5E
AsmCode(i + 20) = &H5B
AsmCode(i + 21) = &H8B: AsmCode(i + 22) = &HE5
AsmCode(i + 23) = &H5D
AsmCode(i + 24) = &HC3
GetClassProcAddr = VarPtr(AsmCode(0))
End Function
Private Sub TimerProc(ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal idEvent As Long, _
ByVal dwTime As Long)
'Debug.Print "类模板中的计时器:", uMsg, idEvent, dwTime
RaiseEvent Timer
End Sub
用法:和vb自带的定时器一致
Option Explicit
Dim WithEvents t As cTimer
Private Sub Form_Load()
Set t = New cTimer
t.Interval = 1000
t.Enabled = True
End Sub
Private Sub t_Timer()
Print Now
End Sub
另外,竹笋大师也发了个支持 vba x64 的timer类,有需要的可以去看看
vba中的Timer定时器,支持64位VBA,VB6也通用_vba计时器-CSDN博客
https://blog.csdn.net/xiaoyao961/article/details/131148204
Views: 62