Attribute VB_Name = "SelfTimer"
Option Explicit
  
Private TimerList() As Long
Private ModulList As New Collection
Private Const WM_TIMER As Long = &H113
Private FirstRun As Boolean

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 Function GetLastError Lib "kernel32" () As Long


Public Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
  Dim I As Integer
  Dim TempID As Integer
  Dim TempOb As Object
  For I = 0 To UBound(TimerList, 2)
    If I > 30000 Then Exit For
    If TimerList(1, I) = idEvent Then
      TempID = CInt(TimerList(0, I))
      Set TempOb = ModulList(I + 1)
      KillTimerByID TempID, TempOb
      TempOb.TimerEvent TempID
      Exit For
    End If
  Next
End Sub

Public Function StartTimer(cModul As Object, ByVal Interval As Long, Optional ByVal ID As Integer = 0) As Long
  Dim I As Integer
  Dim ret As Long
  
  If AppUnloading = True Then Exit Function
  
  If FirstRun = False Then ReDim TimerList(1, 2): FirstRun = True

  If ModulList.Count > 0 Then
    For I = 0 To ModulList.Count - 1
      If TimerList(0, I) = ID And I < ModulList.Count Then
        If cModul Is ModulList(I + 1) Then
          vbKillTimer 0, TimerList(1, I)
          Exit For
        End If
      End If
    Next
  End If

  ret = SetTimer(0, 0, Interval, AddressOf TimerProc)
  If ret = 0 Then
    MsgBox "Fehler: ""vbSetTimer""" & vbCrLf & "Err.LastDLLError: " & Err.LastDllError, vbExclamation
  End If
  
  If I > ModulList.Count Then I = ModulList.Count
  
  If I + 1 > UBound(TimerList, 2) Then ReDim Preserve TimerList(1, I + 16)
  
  TimerList(1, I) = ret
  
  If I = ModulList.Count Then
    ModulList.Add cModul
    TimerList(0, I) = ID
  End If
  
  StartTimer = ret
End Function

Private Function vbKillTimer(ByVal hWnd As Long, ByVal TID) As Boolean
  Dim ret As Long
  Dim Msg As String
  ret = KillTimer(hWnd, TID)
  If ret <> 0 Then
    vbKillTimer = True
  End If
End Function

Public Sub KillTimerByID(ByVal ID As Integer, cModul As Object)
  Dim I As Integer
  Dim EnfT As Boolean
  If ModulList.Count > 0 Then
    For I = 0 To ModulList.Count - 1
      If EnfT = True Then
        TimerList(0, I - 1) = TimerList(0, I)
        TimerList(1, I - 1) = TimerList(1, I)
      End If
      If TimerList(0, I) = ID And EnfT = False And I < ModulList.Count Then
        If cModul Is ModulList(I + 1) Then
          vbKillTimer 0, TimerList(1, I)
          ModulList.Remove I + 1
          If ModulList.Count + 16 < UBound(TimerList) Then ReDim Preserve TimerList(1, ModulList.Count + 4)
          EnfT = True
        End If
      End If
    Next
  End If
End Sub

Public Sub KillAllTimers()
  Dim I As Integer
  If ModulList.Count > 0 Then
    For I = 0 To ModulList.Count - 1
      vbKillTimer 0, TimerList(1, I)
    Next
  End If
End Sub
