API Timer als Klasse Den API Timer in Klassen nutzen - ohne Modul
Autor:   Arne Elster	Bewertung:     [ Jetzt bewerten ]	Views:  18.796
actorics.de/rm_code	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 15 Bewertung insgesamt: gut Durchschnittliche Bewertung: 3.9 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Ab und zu kann es praktisch sein, einen Timer zur Verfügung zu haben, der auch in anderen Klassen statt nur auf Forms verwendet werden kann. Dazu eignet sich der Windows API Timer (SetTimer/KillTimer aus user32). Mit einigen kleinen Tricks lässt sich auch die Abhängigkeit von einem Modul, da der Operator AddressOf ja nur auf Funktionen in diesen angewendet werden kann, umgehen. Mit ein wenig Maschinencode lässt sich so eine Timer Klasse basteln, die sehr einfach in neue Projekte integriert werden kann und vielseitiger nutzbar als die VB Timer Komponente ist.

Aber es ist Vorsicht geboten: In der Entwicklungsumgebung sollte man tunlichst vermeiden, den Stopbutton zu drücken. Auch unerwartet auftretende Fehler im Code, die die Umgebung in den Debugmodus versetzen, könnten zur Instabilität des Timers führen!

Dazu der Code der Klasse "APITimer":

Option Explicit
 
' benötigte API-Deklarationen
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 uIDEvent As Long) As Long
 
Private Declare Sub CopyMem Lib "kernel32" _
  Alias "RtlMoveMemory" ( _
  pDst As Any, _
  pSrc As Any, _
  ByVal cb As Long)
 
Private Declare Function VirtualAlloc Lib "kernel32" ( _
  lpAddress As Any, _
  ByVal dwSize As Long, _
  ByVal flAllocationType As Long, _
  ByVal flProtect As Long) As Long
 
Private Const MEM_COMMIT As Long = &H1000&
 
Private Declare Function VirtualFree Lib "kernel32" ( _
  lpAddress As Any, _
  ByVal dwSize As Long, _
  ByVal dwFreeType As Long) As Long
 
Private Const MEM_DECOMMIT As Long = &H4000&
 
Private Const PAGE_EXECUTE As Long = &H10&
Private Const PAGE_EXECUTE_READ As Long = &H20&
Private Const PAGE_EXECUTE_READWRITE As Long = &H40&
 
Private Const ASM_SIZE As Long = &HFF&
 
Private m_ptrCallback As Long
Private m_hdlTimer As Long
Private m_blnEnabled As Boolean
Private m_lngInterval As Long
 
Public Event Tick()

' muss erste öffentliche Methode in Interface sein!
' API Timer wird diese Methode aufrufen
Public Sub TimerCallback( _
  ByVal hWnd As Long, ByVal uMsg As Long, _
  ByVal idEvent As Long, ByVal dwTime As Long)
 
  RaiseEvent Tick
End Sub

' Aktiviert/Deaktiviert Timer (vgl. VB Intrinsic)
Public Property Get Enabled() As Boolean
  Enabled = m_blnEnabled
End Property
 
Public Property Let Enabled(ByVal blnValue As Boolean)
  If blnValue <> m_blnEnabled Then
    If blnValue Then
      m_hdlTimer = SetTimer(0, 0, IntervalMS, m_ptrCallback)
    Else
      KillTimer 0, m_hdlTimer
    End If
    m_blnEnabled = blnValue
  End If
End Property

' Bestimmt Interval, in dem Tick Event gefeuert wird
' (in Millisekunden)
Public Property Get IntervalMS() As Long
  IntervalMS = m_lngInterval
End Property
 
Public Property Let IntervalMS(ByVal lngMs As Long)
  m_lngInterval = lngMs
 
  If Enabled Then
    ' wird Interval geändert während Timer aktiv ist,
    ' muss er neu initialisiert werden
    Enabled = False
    Enabled = True
  End If
End Property

' Adresse erster öffentlicher Methode eines COM Interfaces ermitteln
Private Function GetFirstPublicMethod(ByVal obj As Object) As Long
  Dim pObj As Long
  Dim pVtbl As Long
 
  ' Adresse über VTable des Interfaces (IUnknown und IDispatch
  ' dort zuerst eingetragen, daher 7 Einträge = &H1C Bytes überspringen)
  CopyMem pObj, ByVal ObjPtr(obj), 4
  CopyMem pVtbl, ByVal pObj + &H1C, 4
 
  GetFirstPublicMethod = pVtbl
End Function

' Für ASM Callback genutzten Speicher freigeben
Private Sub FreeCallback(ByVal ptr As Long)
  VirtualFree ByVal ptr, ASM_SIZE, MEM_DECOMMIT
End Sub

' ASM Callback erstellen, das Timercallbacks an eine
' Methode der Klasse weiterleitet
Private Function CreateCallback(ByVal obj As Object, _
  ByVal addr As Long, ByVal params As Long) As Long
 
  Dim ptrMem As Long
  Dim ptrItr As Long
  Dim ptrNewAddr As Long
  Dim i As Long
  Dim j As Long
 
  ' ausführbaren Speicher vom System holen
  ' und Maschinencode reinschreiben
  ptrMem = VirtualAlloc(ByVal 0&, ASM_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
  If ptrMem = 0 Then
    Err.Raise 12345, , "VirtualAlloc fehlgeschlagen!"
  End If
 
  ptrItr = ptrMem
 
  For i = 1 To params
    CopyMem ByVal ptrItr + 0, &H2474FF, 3 ' PUSH [ESP+imm8]
    CopyMem ByVal ptrItr + 3, params * 4, 1
    ptrItr = ptrItr + 4
  Next 
 
  CopyMem ByVal ptrItr + 0, &H68, 1 ' PUSH imm32
  CopyMem ByVal ptrItr + 1, ObjPtr(obj), 4
  ptrItr = ptrItr + 5
 
  ptrNewAddr = addr - ptrItr - 5
 
  CopyMem ByVal ptrItr + 0, &HE8, 1 ' CALL rel32
  CopyMem ByVal ptrItr + 1, ptrNewAddr, 4
  ptrItr = ptrItr + 5
 
  CopyMem ByVal ptrItr + 0, &HC2, 1 ' RET imm16
  CopyMem ByVal ptrItr + 1, params * 4, 2
 
  CreateCallback = ptrMem
End Function

Private Sub Class_Initialize()
  m_ptrCallback = CreateCallback(Me, GetFirstPublicMethod(Me), 4)
End Sub

Private Sub Class_Terminate()
  If Enabled Then Enabled = False
  FreeCallback m_ptrCallback
End Sub

Code für eine Testform mit 2 Listboxen namens "List1" und "List2":

Option Explicit
 
' OBACHT VOR DEM STOP BUTTON!
'
' Die Timer müssen ordentlich entladen werden,
' sonst kann es zu unerklärlichen Abstürzen
' oder anderem seltsamen Verhalten während
' der Entwicklungszeit kommen!
 
Private WithEvents m_clsTimer1 As APITimer
Private WithEvents m_clsTimer2 As APITimer

Private Sub Form_Load()
  Set m_clsTimer1 = New APITimer
  Set m_clsTimer2 = New APITimer
 
  m_clsTimer1.IntervalMS = 1000
  m_clsTimer1.Enabled = True
 
  m_clsTimer2.IntervalMS = 2000
  m_clsTimer2.Enabled = True
End Sub

Private Sub m_clsTimer1_Tick()
  List1.AddItem "Tick!"
End Sub

Private Sub m_clsTimer2_Tick()
  List2.AddItem "Tick!"
End Sub