Thomas Risi Softwareentwicklung

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 ' Timer1 Stopp Private Sub CommandButton1_Click() ' Beendet Timer1 Timer1.Destroy End Sub ' Timer2 Start/Stopp Private Sub CommandButton2_Click() If Timer2.ID = 0 Then ' Startet Timer2 (100 ms) Timer2.Create 100 Else ' Beendet Timer2 Timer2.Destroy End If End Sub ' Inkrementiert n (1000 ms) und schreibt in TextBox1 Private Sub Timer1_OnTime() Static n&: n = n + 1 Me.TextBox1 = n End Sub ' Inkrementiert n (100 ms) und schreibt in TextBox2 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 ' Startet Timer (1000 ms) 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

Bewerten Sie bitte dieses Programm.
1 2 3 4 5
Weniger nützlich Sehr nützlich
Bitte teilen Sie uns mit, warum Sie das Programm so bewertet haben. (optional)