vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
sevDataGrid - Gönnen Sie Ihrem SQL-Kommando diesen krönenden Abschluß!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2017
 
zurück
Rubrik: Datum/Zeit und Timer · Timer   |   VB-Versionen: VB626.06.08
API Timer als Klasse

Den API Timer in Klassen nutzen - ohne Modul

Autor:   Arne ElsterBewertung:     [ Jetzt bewerten ]Views:  12.702 
actorics.de/rm_codeSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

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

Dieser Tipp wurde bereits 12.702 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2017 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel