Application.OnTime with passed parameters

[RawlinsCross]

I have a launched userform that contains a label that counts (in minutes) how long the userform is open. Every minute the userform label is adjustment upwards by 1 minute. Now, there could be several of these userforms open, each counting up the time from when they were open.

I got the counting to work but I can't cancel the OnTime when I close the userform.

My strategy is as follows:
1. When you open a userform, you time stamp a time in a public property of the userform. This will be used to cancel it.
2. Form my understanding, OnTime can't be used to call methods inside a userform (am I wrong on this?) so I have to pass the userform around to the various methods.

This is what I have tried so far:

When you launch the userform:
Inside the userform module

Private mdRunTime As Date

'Public Property
Public Property Let RunTime(dRunTime As Date)
mdRunTime = dRunTime
End Property

Public Property Get RunTime() As Date
RunTime = mdRunTime
End Property

Private Sub UserForm_Initialize()
Call StartDuration(Me)
End Sub

'Stopping the timer when you close the userform
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call StopIt(Me)
End Sub

Inside Module

Public Sub UpdateDuration(frm As DataEntryDetails)
'This code does the counting
Dim dStartTime As Date
Dim dNowTime As Date
Dim lDiffTime As Long
Dim frm As Object

For Each frm In VBA.UserForms
     If frm.Name = "DataEntryDetails" Then
         'Get start/current time of event
         dStartTime = CDate(frm.lblDate.Caption) + CDate(frm.lblTime.Caption)
         dNowTime = Now

         lDiffTime = DateDiff("n", dStartTime, dNowTime)
     End If
Next frm

Call StartDuration(frm)

End Sub

Public Sub StartDuration(frm As DataEntryDetails)

frm.RunTime = Now + TimeValue("00:01:00")
Application.OnTime frm.RunTime, "'UpdateDuration frm'"

End Sub

Public Sub StopIt(frm As DataEntryDetails)

On Error Resume Next
Application.OnTime frm.RunTime, "'UpdateDuration frm'", , False
On Error GoTo 0

End Sub

 

[Legacy 456155]

It might be easier to create a single timer and have each of your userforms subscribe to it.
To use this example, add a standard module and copy in the following code. Add a userform with Label1. Copy in the userform code below.
Now open as many instances of the userform as you wish. They will subscribe and unsubscribe automatically, using a single timer.
Download example: "UserForm OnTime.xlsm" in this folder.

In a standard module:

Option Explicit

Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal Hwnd As LongLong) As LongLong

Private Subscribers As New Collection
Private NextTick As Date

Sub Subscribe(Caller As Object)
    Dim UserFormHwnd As Long
    IUnknown_GetWindow Caller, VarPtr(UserFormHwnd)
    Caller.Hwnd = UserFormHwnd
    Subscribers.Add Caller, CStr(UserFormHwnd)
    If Subscribers.Count = 1 Then TickAway
End Sub

Sub UnSubscribe(UserFormHwnd As Long)
    Subscribers.Remove CStr(UserFormHwnd)
    If Subscribers.Count = 0 Then Application.OnTime NextTick, "TickAway", , False
End Sub

Sub TickAway()
    NextTick = Now + TimeSerial(0, 0, 1)
    Application.OnTime NextTick, "TickAway"
   
    Dim Subscriber As Object
    For Each Subscriber In Subscribers
        Call Subscriber.Timer
    Next
End Sub

In any userform that wishes to subscribe to the timer:

Private FormOpenTime As Date
Public Hwnd As Long

Private Sub UserForm_Initialize()
    FormOpenTime = Now
    Subscribe Me
End Sub

Private Sub UserForm_Terminate()
    UnSubscribe Hwnd
End Sub

Public Sub Timer()
    Label1 = Format(Now - FormOpenTime, "HH:MM:SS")
End Sub

 

[RawlinsCross]

DataLuver - you again! hahaha.. thanks for the reply. Will go through the code, see you're using the Windows API - always very intimating for me. But this seems digestible enough. Let me take it away and see what I can figure out. May have questions if you wouldn't mind.

 

[Legacy 456155]

May have questions if you wouldn't mind.

Questions? Here? On this message-board?

 

[RawlinsCross]

Yes, quite!

Okay, to get this started, I've downloaded the test-file. Clicked the button "Create Some Userforms" and immediately get a compile error on the Windows API function call. Am I missing a library here?

 

[Legacy 456155]

Replace the problem line with these five lines:

#If VBA7 Then
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal Hwnd As LongPtr) As LongPtr
#Else
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal Hwnd As Long ) As Long
#End If

I updated the example as well.
You have the library if you have windows.

 

[RawlinsCross]

So, first question - is there something I can call you other than "dataluver" - I mean, I have no problem calling you dataluver of course (I'm one too).

So really neat getting into this code.

I've run your code, no problem. Having an error when I try to incorporate it into my own project. The effectedine is "Caller.Hwnd = UserFormHwnd". UserFormHwnd is returning 0 rather than some larger number (789606) when I ran it on your spreadsheet. Any thoughts?

 

[Legacy 456155]

You can call me Tom. That's what everybody's been calling me my entire life! That's also my name.
As for your error, I suspect that we are missing "Public Hwnd As Long" in the userform or you have declared it as private. It must be public.
There are other ways to index your userforms if we keep running into problems. Out of habit, I usually use the window handle as a key because it's guaranteed, I think, to be unique, but I suppose that we could have gone with something along the lines of an index such as the collection's count when each form reference is being added. This following code is just as functional and easier to read IMO. I updated the example.

Private Subscribers As New Collection
Private NextTick As Date

Sub Subscribe(Caller As Object)
    Caller.Key = CStr(Subscribers.Count)
    Subscribers.Add Caller, Caller.Key
    If Subscribers.Count = 1 Then TickAway
End Sub

Sub UnSubscribe(Caller As Object)
    Subscribers.Remove Caller.Key
    If Subscribers.Count = 0 Then Application.OnTime NextTick, "TickAway", , False
End Sub

Sub TickAway()
    NextTick = Now + TimeSerial(0, 0, 1)
    Application.OnTime NextTick, "TickAway"
   
    Dim Subscriber As Object
    For Each Subscriber In Subscribers
        Call Subscriber.Timer
    Next
End Sub

Private FormOpenTime As Date
Public Key As String

Private Sub UserForm_Initialize()
    FormOpenTime = Now
    Subscribe Me
End Sub

Private Sub UserForm_Terminate()
    UnSubscribe Me
End Sub

Public Sub Timer()
    Label1 = Format(Now - FormOpenTime, "HH:MM:SS")
End Sub

 

[RawlinsCross]

Yeah, I forgot to declare Hwnd so fixed that so your first suggestion code works just fine. I'll look at the second suggestion code as well.

One thing I figured is that with this Subscribers collection that I didn't need the myRefs collection you mentioned in a previous thread (remember: the disappearing references to those userforms). I was right - the Subscribers collection holds the references when you minimize and then maximize excel. Two collections would have been sloppy.

This was a very educational thread for me, thanks a tonne Tom.

 

[RawlinsCross]

Found a lot more information on this topic on another mrexcel thread. How deep is this rabbit hole?

A much simpler alternative to the FindWindow API for retrieving the HWND of UserForms

Hi all, Just wanted to share this little known API function for those who need to retrieve the Window handle (hwnd) of a userform. As you all know, the standard approach is to use the FindWindow API but this has two awkward issues : Declare Function FindWindow Lib "user32" Alias...

www.mrexcel.com