Option Explicit
 
Public Declare Function SetTimer _
                          Lib "user32" _
                          (ByVal hwnd As Long, _
                           ByVal nIDEvent As Long, _
                           ByVal uElapse As Long, _
                           ByVal lpTimerFunc As Long) As Long
 
Public Declare Function KillTimer _
                          Lib "user32" _
                          (ByVal hwnd As Long, _
                           ByVal nIDEvent As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" Alias _
        "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, _
        ByVal cbCopy As Long)
 
'Die Collection myColPtrs speichert die Pointer
'auf alle Klassen, die einen API-Timer aktiviert
'haben. Anhand dieser Pointer wird
'in TimerProc das Objekt ermittelt, das diesen
'API-Timer erzeugt hat
Private myColPtrs As Collection
 
Public Sub TimerProc(ByVal hwnd&, ByVal uMsg&, ByVal idEvent&, ByVal dwTime&)
   Dim oTimer As ApiTimer
   Dim ptr&
   On Error Resume Next
   'wir holen den Pointer auf das Objekt, die diesen
   'Timer erzeugt hat
   ptr = GetPtr(idEvent)
   If ptr <> 0 Then
      'wir holen einen Verweis auf das Objekt...
      Set oTimer = PtrToObject(ptr)
      If Not oTimer Is Nothing Then
         '...und rufen seien Callback-Funktion auf
         oTimer.TmrCallBack
         Set oTimer = Nothing
      End If
   End If
 
End Sub
 
 
'Startet den API-Timer und gibt im Erfolgsfall die Timer-Id zurück
'bei Mißerfolg: Rückgabe von 0
'Funktion will den Pointer auf das aufgerufende ApiTimer-Objekt
Public Function VBStartTimer(ByVal ptrObject&, ByVal timeOut&)
   Dim id&
 
   id = SetTimer(0, 0, timeOut, AddressOf TimerProc)
   VBStartTimer = id
   If id <> 0 Then
      'wenn der Timer erfolgreich gestartet wurde:
      'den Pointer auf das aufrufende Objekt merken
      'damit es später in TimerProc ermittelt werden
      'kann
      On Error Resume Next
      If myColPtrs Is Nothing Then
         Set myColPtrs = New Collection
      End If
      myColPtrs.Add ptrObject, Hex(id)
   End If
 
End Function
 
Public Function VBKillTimer(ByVal id&)
   On Error Resume Next
   VBKillTimer = KillTimer(0, id)
   myColPtrs.Remove Hex(id)
   If myColPtrs.Count = 0 Then
      Set myColPtrs = Nothing
   End If
End Function
 
Private Function GetPtr(id&) As Long
   Dim idx&, ptr&
   On Error Resume Next
   ptr = myColPtrs(Hex(id))
   GetPtr = ptr
End Function
 
Public Function PtrToObject(ByVal lngPtr As Long) As Object
   Dim nObj As Object
 
   If lngPtr <> 0 Then
      CopyMemory nObj, lngPtr, 4
   End If
   Set PtrToObject = nObj
 
   CopyMemory nObj, 0&, 4
End Function