Rem. Module de servive effecteur de tâches des objets Rythmeur.
' NE PAS UTILISER EN PROGRAMMATION APPLICATIVE.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare PtrSafe Function SetTimer Lib "user32.dll" _
(ByVal Hwnd As Long, ByVal Idt As Long, ByVal DuréeMS As Long, ByVal AdrSub As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32.dll" _
(ByVal Hwnd As Long, ByVal Idt As Long) As Long
#Else
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Function SetTimer Lib "user32.dll" _
(ByVal Hwnd As Long, ByVal Idt As Long, ByVal DuréeMS As Long, ByVal AdrSub As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" _
(ByVal Hwnd As Long, ByVal Idt As Long) As Long
#End If
Private TRythmeurs() As Rythmeur, Idt As Long
Public Function IdtRythmeurLancé(ByVal Ryth As Rythmeur, ByVal FréqHz As Double, ByRef Tac As Long) As Long
Dim P As Long, M As Long
On Error Resume Next: M = UBound(TRythmeurs): If Err Then ReDim TRythmeurs(1 To 1): M = 1
On Error GoTo 0
For P = 1 To M: Idt = Idt Mod M + 1
If TRythmeurs(Idt) Is Nothing Then Exit For
Next P
If P > M Then ReDim Preserve TRythmeurs(1 To P): Idt = P
Set TRythmeurs(Idt) = Ryth
SetTimer ThisWorkbook.Windows(1).Hwnd, Idt:=Idt, DuréeMS:=Int(1000 / FréqHz + 0.5), AdrSub:=AddressOf TimerProc
Tac = GetTickCount: IdtRythmeurLancé = Idt
End Function
Public Sub StopperRythmeur(ByVal Idt As Long)
On Error Resume Next
KillTimer ThisWorkbook.Windows(1).Hwnd, Idt
Set TRythmeurs(Idt) = Nothing
End Sub
Private Sub TimerProc(ByVal Hwnd As Long, ByVal uMsg As Long, ByVal Idt As Long, ByVal Tic As Long)
On Error Resume Next
TRythmeurs(Idt).Actionner Tic
If Err Then KillTimer Hwnd, Idt
End Sub
