Thomas Risi Softwareentwicklung
Addins - Datenbanklösungen - Komponenten - RTDServer - WebServices
CTimer - Eine HARDCORE-Timerklasse
Mit dieser Klasse kann man richtige TimerEvents für VBA erzeugen. Kopieren Sie die Klasse in jedes Projekt in dem Sie einen
(oder auch mehrere) Timer benötigen.
Den Code für das Klassenmodul CTimer genau so einfügen wie angegeben!
Quellcode für eine UserForm (mit zwei CommandButtons, und zwei TextBoxes) ...
Option Explicit
Private WithEvents Timer1 As cTimer
Private WithEvents Timer2 As cTimer
Private Sub CommandButton1_Click()
Timer1.Destroy
End Sub
Private Sub CommandButton2_Click()
If Timer2.ID = 0 Then
Timer2.Create 100
Else
Timer2.Destroy
End If
End Sub
Private Sub Timer1_OnTime()
Static n&: n = n + 1
Me.TextBox1 = n
End Sub
Private Sub Timer2_OnTime()
Static n&: n = n + 1
If n < 100 Then
Me.TextBox2 = n
Else
n = 0
Timer2.Destroy
End If
End Sub
Private Sub UserForm_Initialize()
Me.Caption = " Unsere kleine Form"
Me.TextBox1 = 0
Me.TextBox2 = 0
Set Timer1 = New cTimer
Set Timer2 = New cTimer
Timer1.Create 1000
End Sub
Private Sub UserForm_Terminate()
Set Timer1 = Nothing
Set Timer2 = Nothing
End Sub
Quellcode für Klassenmodul CTimer ...
Option Explicit
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 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private m_asm() As Byte
Private m_obj As Long
Private m_fnc As Long
Private m_id As Long
Private Const ASMCODE As String = "558BEC50FF7514FF7510FF750CFF75086800000000B800000000FFD0C9C21000"
Event OnTime()
Public Sub TimerProc( _
ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
RaiseEvent OnTime
End Sub
Public Property Get ID() As Long
ID = m_id
End Property
Public Sub Create(ms As Long)
If ms < 50 Then _
ms = 1000
Call CreateTimer(ms)
End Sub
Public Sub Destroy()
Call DestroyTimer
End Sub
Private Sub Class_Initialize()
m_obj = ObjPtr(Me)
m_fnc = CreateASMContainer(ObjPtr(Me), 0)
End Sub
Private Sub Class_Terminate()
Call DestroyTimer
End Sub
Private Function CreateTimer(ByVal ms As Long) As Long
Dim ret As Long
If m_id = 0& Then
ret = SetTimer(0&, 0&, ms, m_fnc)
If ret <> 0 Then
m_id = ret
CreateTimer = ret
End If
Else
CreateTimer = m_id
End If
End Function
Private Function DestroyTimer() As Long
Dim ret As Long
If m_id <> 0 Then
ret = KillTimer(0&, m_id)
If ret <> 0 Then
m_id = 0
End If
End If
End Function
Private Function GetProcPtr(cp As Long, pn As Long) As Long
Dim pt As Long
Dim pp As Long
CopyMemory pt, ByVal cp, 4
CopyMemory pp, ByVal pt + &H1C& + (4 * pn), 4
GetProcPtr = pp
End Function
Private Function CreateASMContainer(cp As Long, pn As Long) As Long
Dim pp As Long
pp = GetProcPtr(cp, pn)
Dim n As Long: n = Len(ASMCODE) \ 2 - 1
ReDim m_asm(0 To n)
Dim i As Long
For i = 0 To n
m_asm(i) = "&H" & Mid$(ASMCODE, i * 2 + 1, 2)
Next
CopyMemory m_asm(17), cp, 4
CopyMemory m_asm(22), pp, 4
CreateASMContainer = VarPtr(m_asm(0))
End Function
© 2001 -
by Thomas Risi