TimerEx for vb6,vba x64, Timer in vb6 Class

TimerEx.cls

Code:

---

Option Explicit
Dim DoTimes As Long
Dim m_Interval As Long, m_Enabled As Boolean, lngTimerID As Long
Public Event Timer()
Sub TimerProc()
    RaiseEvent Timer
End Sub
Public Property Get Interval() As Long
    Interval = m_Interval
End Property
Public Property Let Interval(ByVal New_Value As Long)
    If New_Value >= 0 Then m_Interval = New_Value
End Property
Public Property Get Enabled() As Boolean
    Enabled = m_Enabled
End Property
Public Property Let Enabled(ByVal New_Value As Boolean)
    m_Enabled = New_Value
    If lngTimerID <> 0 Then ClassUnloadTimer
    If m_Enabled And m_Interval > 0 Then
        lngTimerID = SetTimer(0, 0, m_Interval, AddressOf TimerExProc)
        TimerExClass.Add Me, lngTimerID & ""
    End If
End Property

Sub ClassUnloadTimer()
    If lngTimerID <> 0 Then
        KillTimer 0, lngTimerID
        TimerExClass.Remove lngTimerID & ""
        lngTimerID = 0
    End If
End Sub
Private Sub Class_Terminate()
    ClassUnloadTimer
End Sub

---

module1.bas

Code:

---

Option Explicit
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal Hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal Hwnd As Long, ByVal nIDEvent As Long) As Long

Public Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal Hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, Optional ByVal wType As Long) As Long

Public TimerExClass As New Collection

Public Sub TimerExProc(ByVal Hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    On Error GoTo ERR
    Dim Ex As TimerEx
    Set Ex = TimerExClass(idEvent & "")
    Ex.TimerProc
    Exit Sub
ERR:      Msgbox "TimerExProc ERR:" & ERR.Description
End Sub

Function Msgbox(ByVal Txt As String, Optional ByVal Title As String)
  ' If Title = "" Then Title = App.Title
    MessageBox 0, Txt, Title, 0
End Function

---

test in form1.frm

Code:

---

Dim WithEvents TimerEx1 As TimerEx
Dim WithEvents TimerEx2 As TimerEx

Private Sub Command1_Click()
Set TimerEx1 = New TimerEx
Set TimerEx2 = New TimerEx
TimerEx2.Interval = 1000
TimerEx1.Interval = 2000
TimerEx1.Enabled = True
TimerEx2.Enabled = True
End Sub

Private Sub TimerEx1_Timer()
    Static id As Long
    id = id + 1
    If id > 3 Then id = 0: TimerEx1.Enabled = False
    Msgbox "TimerEx1-" & id
End Sub
Private Sub TimerEx2_Timer()
    Static id As Long
    id = id + 1
    If id > 3 Then id = 0: TimerEx2.Enabled = False
    Msgbox "TimerEx2-" & id
End Sub

---

WHY IT'S ERR IN VB6 OR VBA X64?

Finally a Timer class in VBA | Access World Forums
https://www.access-programmers.co.uk...in-vba.232012/

Wanted multiple timer events without having to use a form timer.

Have been accepting that callback functions can not be used in a VBA class like msaccess until got a hint from vb.mvps.org

Using the following declarations in my VBA class:

Code:

---


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


Public Event OnTimer()

Private TimerID As Long

'Start timer
Public Sub Startit(IntervalMs As Long)
    TimerID = SetTimer(Application.hWndAccessApp, ObjPtr(Me), IntervalMs, AddressOf Timers.TimerProc)
End Sub

'Stop timer
Public Sub Stopit()
    If TimerID <> -1 Then
        KillTimer 0&, TimerID
        TimerID = 0
    End If
End Sub


'Trigger Public event
Public Sub RaiseTimerEvent()
    RaiseEvent OnTimer
End Sub

---

Please notice the use of the call to undocumented VBA function ObjPtr(Me) with the instance of the class when SetTimer is called.

Then created a module named "Timers" to place the callback function:

Code:

---

Public Sub TimerProc(ByVal hWnd As Long, _
                    ByVal uMsg As Long, _
                    ByVal oTimer As clsTimer, _
                    ByVal dwTime As Long)
  ' Alert appropriate timer object instance.
  If Not oTimer Is Nothing Then
    oTimer.RaiseTimerEvent
  End If
End Sub

---

FORM1.FRM

Code:

---

Dim WithEvents HappyTimer As clsTimer

'Start the timer
Private Sub StartMyTimer()
  Set HappyTimer = New clsTimer
  HappyTimer.Startit 2000
End Sub

'Using the timer event from the timer
Private Sub HappyTimer_OnTimer()
    Debug.Print "Timer Event " & Now
End Sub

---

thetrik/VbTrickTimer: CTrickTimer - the timer class for VB6/VBA compatible with 64 bit office.
https://github.com/thetrik/VbTrickTimer

https://www.vbforums.com/showthread....=1#post5473119

Quote:

---

Originally Posted by JAAFAR

I want this simply for learning purposes.

As an example I would want to see if I can keep a SetTimer API callback routine within a class module without the need for an additional standard module.

I'll start a new thread later.

Thanks for responding.

EDIT
How did you get the &H258 ?

---