I'm building a form that can take the values from the clipboard and auto fill itself.
In order to get the values I use application.ontime to run a macro every two seconds and read the clipboard. The start is done in userform initialize.
That works fine.
Sub Userform_Initialize()
On Error Resume Next
fireTime = Now + TimeValue("00:00:02")
Application.OnTime EarliestTime:=fireTime, Procedure:="copy", Schedule:=True
On Error GoTo 0
End Sub
If I close the userform I added a queryclose to make sure the copy macro stops:
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.OnTime EarliestTime:=fireTime, Procedure:="copy", Schedule:=False
End Sub
Works fine also.
The actual macro is this:
Public fireTime As Date
Sub copy()
On Error GoTo ErrHandler
Dim oData As New DataObject
Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
DataObj.GetFromClipboard
strPaste = DataObj.GetText(1)
Row1 = Split(strPaste, vbNewLine)(0)
col = Split(Row1, vbTab)
If UBound(Split(col(14), "-")) = 2 Then
If Len(col(0)) = 7 Then
If Left(col(3), 4) = "4600" Then
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard 'take in the clipboard to empty it
UF_RegistreraVM.TB_LevNr.Text = col(0)
Levnr = col(0)
' ... and so on..
'Line below does not work
Application.OnTime EarliestTime:=fireTime, Procedure:="copy", Schedule:=False
Exit Sub
End If
End If
End If
ErrHandler:
On Error Resume Next
fireTime = Now + TimeValue("00:00:02")
Application.OnTime EarliestTime:=fireTime, Procedure:="copy", Schedule:=True
On Error GoTo 0
End Sub
And the only line that does not work is when I set application.ontime to false in the nested ifs.
That line is the same as the one in queryclose, but it doesn't work here.
When I debug the code errors on that line and due to On Error GoTo ErrHandler it jums down to ErrHandler and sets a new time to run the macro.
What is the issue that with the code, why can't I turn of the ontime inside the ifs?
Related
VBA code for autosaving and for closing the workbook if idle is working. The problem is, Excel continues to run the code if another instance of the program was open when the code closed the workbook. I think what I need to do is to unload the workbook, but I can't figure out how. I've tried "Unload Workbook," "Unload ThisWorkbook," and "Unload ResetTimer" [the module which detects activity and starts the 35 minute timer over]. I'm getting an error that Workbook/ThisWorkbook/ResetTimer are not object that can be unloaded. I can't find a list of what objects can be unloaded.
Here is the code under ThisWorkbook
Option Explicit
Private Sub ThisWorkbook_Open()
If ThisWorkbook.ReadOnly = False Then
Application.OnTime Now + TimeValue("00:30:00"), "SaveThis"
End If
If ThisWorkbook.ReadOnly = False Then
Application.OnTime Now + TimeValue("00:35:00"), "CloseDownFile"
End If
End Sub
Private Sub ThisWorkbook_Close()
Unload ThisWorkbook
' Unload ResetTimer
End Sub
Private Sub ThisWorkbook_SheetCalculate(ByVal Sh As Object)
ResetTimer
End Sub
Private Sub ThisWorkbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
ResetTimer
End Sub
Private Sub ThisWorkbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
ResetTimer
End Sub
Here is the Module:
Public CloseDownTime As Variant
Public Sub ResetTimer()
On Error Resume Next
If Not IsEmpty(CloseDownTime) Then Application.OnTime EarliestTime:=CloseDownTime, Procedure:="CloseDownFile", Schedule:=False
CloseDownTime = Now + TimeValue("00:35:00") ' change as needed
Application.OnTime CloseDownTime, "CloseDownFile"
End Sub
Public Sub CloseDownFile()
On Error Resume Next
ThisWorkbook.Close SaveChanges:=True
Unload ThisWorkbook
End Sub
Sub SaveThis()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
Application.OnTime Now + TimeValue("00:30:00"), "SaveThis"
End Sub
Your regular module should look more like this (see below). This removes the logic from your ThisWorkbook module.
Option Explicit
Public CloseTime As Variant
Public SaveTime As Variant
Public Sub StartTimers()
StartSaveTimer
StartCloseTimer
End Sub
Public Sub CancelTimers()
CancelSaveTimer
CancelCloseTimer
End Sub
Sub StartSaveTimer()
If ThisWorkbook.ReadOnly Then Exit Sub
CancelSaveTimer 'remove any existing timer
SaveTime = Now + TimeValue("00:30:00")
Application.OnTime SaveTime, "SaveThis"
End Sub
Sub CancelSaveTimer()
On Error Resume Next
Application.OnTime EarliestTime:=SaveTime, Procedure:="SaveThis", Schedule:=False
On Error GoTo 0
End Sub
Sub StartCloseTimer()
If ThisWorkbook.ReadOnly Then Exit Sub
CancelCloseTimer 'remove any existing timer
CloseTime = Now + TimeValue("00:35:00")
Application.OnTime CloseTime, "CloseThis"
End Sub
Sub CancelCloseTimer()
On Error Resume Next
Application.OnTime EarliestTime:=CloseTime, Procedure:="CloseThis", Schedule:=False
On Error GoTo 0
End Sub
Public Sub CloseThis()
On Error Resume Next
CancelTimers
ThisWorkbook.Close SaveChanges:=True
End Sub
Sub SaveThis()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
StartSaveTimer
End Sub
Here is the corrected code to save every 30 minutes and to close after 35 minutes of no use. Thank you to #TimWilliams for all of the help!
Code under ThisWorkbook:
Option Explicit
Private Sub Workbook_Open()
Call StartTimers
End Sub
Private Sub Workbook_Close()
CancelTimers
End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
CancelCloseTimer
StartCloseTimer
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
CancelCloseTimer
StartCloseTimer
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
CancelCloseTimer
StartCloseTimer
End Sub
Code for Module:
Option Explicit
Public CloseTime As Variant
Public SaveTime As Variant
Public Sub StartTimers()
StartSaveTimer
StartCloseTimer
End Sub
Public Sub CancelTimers()
CancelSaveTimer
CancelCloseTimer
End Sub
Sub StartSaveTimer()
If ThisWorkbook.ReadOnly Then Exit Sub
CancelSaveTimer 'remove any existing timer
SaveTime = Now + TimeValue("00:30:00") 'save frequency, change as needed
Application.OnTime SaveTime, "SaveThis"
End Sub
Sub CancelSaveTimer()
On Error Resume Next
Application.OnTime EarliestTime:=SaveTime, Procedure:="SaveThis", Schedule:=False
On Error GoTo 0
End Sub
Sub StartCloseTimer()
If ThisWorkbook.ReadOnly Then Exit Sub
CancelCloseTimer 'remove any existing timer
CloseTime = Now + TimeValue("00:35:00") 'idle time before closing, change as needed
Application.OnTime CloseTime, "CloseThis"
End Sub
Sub CancelCloseTimer()
On Error Resume Next
Application.OnTime EarliestTime:=CloseTime, Procedure:="CloseThis", Schedule:=False
On Error GoTo 0
End Sub
Public Sub CloseThis()
On Error Resume Next
CancelTimers
ThisWorkbook.Close SaveChanges:=True
End Sub
Sub SaveThis()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
StartSaveTimer
End Sub
Just want to ask if why do I keep receiving this error?
Run-time error '1004': Method 'OnTime' of object'_Application' failed
So, I'm trying to close my workbook but whenever I'm doing it, the error shows. The highlighted line after clicking the Debug button is Application.OnTime timeCheck, "SaveThis", , False in the Workbook_BeforeClose sub. What seems to be the problem here?
Private Sub Workbook_Open() 'place in ThisWorkbook
timeCheck = Now + TimeValue("00:15:00")
Application.OnTime timeCheck, "SaveThis"
End Sub
Sub SaveThis() 'place in Module
timeCheck = Now + TimeValue("00:15:00")
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
Application.OnTime timeCheck, "SaveThis"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean) 'place in ThisWorkbook
Application.OnTime timeCheck, "SaveThis", , False
End Sub
It seems to me that you are trying to schedule a call to SaveThis() in the future, right when the application is about to close. Why would you want to do that?, if the error never happened, then how will you guarantee that the call happens when the workbook is already closed?
If what you meant to do is save the workbook before closing the workbook, then you will need to change your code as follows:
Private Sub Workbook_Open() 'place in ThisWorkbook
timeCheck = Now + TimeValue("00:15:00")
Application.OnTime timeCheck, "SaveThis"
End Sub
Sub SaveThis()
timeCheck = Now + TimeValue("00:15:00")
SaveRightNow ' This is a new sub that you will need to add
Application.OnTime timeCheck, "SaveThis"
End Sub
Sub SaveRightNow()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean) 'place in ThisWorkbook
SaveRightNow ' Saves the workbook without having to schedule a call in the future
End Sub
I hope someone can help me about problem that i have.
I created workbook than will on opening start few macros:
Refresh_time - runs every second to update time counter
Save_it - saves file on every 30 minutes
Order - runs marco Save_order at specific time, 02, 10 and 18 hours
Also there is few marcos which will close file if there is no activity for 10 minutes.
In both cases, if file is closed due to inactivity or closed manualy, it keeps opening by it self.
Do anybody have idea where i have made mistake?
In ThisWorkbook
Private Sub Workbook_Open()
Refresh_time
Save_it
Order
TimeSetting
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.Save
Stop_
TimeStop
On Error GoTo 0
Application.DisplayAlerts = True
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
TimeStop
TimeSetting
End Sub
In Module1
Public dTimeB, dTimeS, dTimeT1, dTimeT2, dTimeT3, CloseTime As Date
Sub Stop_()
Application.OnTime dTimeB, "Refresh_time", , False
Application.OnTime dTimeS, "Save_it", , False
Application.OnTime dTimeT1, "Save_order", , False
Application.OnTime dTimeT2, "Save_order", , False
Application.OnTime dTimeT3, "Save_order", , False
End Sub
Sub TimeSetting()
On Error Resume Next
Application.OnTime EarliestTime:=CloseTime, Procedure:="SavedAndClose", Schedule:=False
On Error GoTo 0
CloseTime = Now() + TimeValue("00:03:00")
Application.OnTime EarliestTime:=CloseTime, Procedure:="SavedAndClose", Schedule:=True
End Sub
Sub TimeStop()
On Error Resume Next
Application.OnTime EarliestTime:=CloseTime, _
Procedure:="SavedAndClose", Schedule:=False
End Sub
Sub SavedAndClose()
ActiveWorkbook.Close Savechanges:=True
End Sub
Sub Refresh_time()
Dim Smena_1, Smena_2, Smena_3 As Date
On Error Resume Next
Application.OnTime EarliestTime:=dTimeB, Procedure:="Refresh_time", Schedule:=False
On Error GoTo 0
dTimeB = Now() + TimeValue("00:00:01")
Application.OnTime EarliestTime:=dTimeB, Procedure:="Refresh_time", Schedule:=True
Smena_1 = Date + TimeValue("10:00:00")
Smena_2 = Date + TimeValue("18:00:00")
Smena_3 = Date + 1 + TimeValue("02:00:00")
vreme = Date + Time
If vreme < Smena_1 Then
Y = Smena_1 - vreme
Else
If vreme < Smena_2 Then
Y = Smena_2 - vreme
Else
Y = Smena_3 - vreme
End If
End If
Workbooks("Lager MES REO zica_MM.xlsm").Worksheets("Pocetna").Vreme_porucivanja.Value = Format(Y, "hh:mm:ss")
Workbooks("Lager MES REO zica_MM.xlsm").Worksheets("Pocetna").Za_porucivanje.Value = Application.CountA(Workbooks("Lager MES REO zica_MM.xlsm").Worksheets("Za porucivanje").Range("A:A")) - 1
End Sub
Sub Save_it()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
On Error Resume Next
Application.OnTime EarliestTime:=dTimeS, Procedure:="Save_it", Schedule:=False
On Error GoTo 0
dTimeS = Now() + TimeValue("00:10:00")
Application.OnTime EarliestTime:=dTimeS, Procedure:="Save_it", Schedule:=True
End Sub
Sub Order()
On Error Resume Next
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=False
On Error GoTo 0
dTimeT1 = TimeValue("02:00:00")
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=True
On Error Resume Next
Application.OnTime EarliestTime:=dTimeT2, Procedure:="Save_order", Schedule:=False
On Error GoTo 0
dTimeT2 = TimeValue("10:00:00")
Application.OnTime EarliestTime:=dTimeT2, Procedure:="Save_order", Schedule:=True
On Error Resume Next
Application.OnTime EarliestTime:=dTimeT3, Procedure:="Save_order", Schedule:=False
On Error GoTo 0
dTimeT3 = TimeValue("18:00:00")
Application.OnTime EarliestTime:=dTimeT3, Procedure:="Save_order", Schedule:=True
End Sub
I did as you suggested, but still is not ok (code is updated). Also, when Order macro run, lets say at 10:00, it runs 3 times. Can you help me with this little more?
You are doing most things correct with application.ontime. But there is one thing you should add. Before setting a new ontime delete the previous.
As an example:
dTimeT1 = now() + TimeValue("00:10:00")
Application.OnTime dTimeT1, "Save_order"
I would change that too:
on error resume next ' in case dTimeT1 is not set
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=False
on error goto 0
dTimeT1 = now() + TimeValue("00:10:00")
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=True
Because if dTimeT1 is a time in the future you could end up with two application.ontimes set but you can't remove the previous because your variable has been changed.
So always clear the previous one then set a new. This issue occurs when you run the macro manually.
Specific to your question:
I'm not sure about your stop function. Why do you first set a schedule then remove it?
Why not just?
Sub Stop_()
on error resume next
Application.OnTime EarliestTime:=dTimeB, Procedure:="Refresh_time", Schedule:=False
Application.OnTime EarliestTime:=dTimeS, Procedure:="Save_it", Schedule:=False
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=False
Application.OnTime EarliestTime:=dTimeT2, Procedure:="Save_order", Schedule:=False
Application.OnTime EarliestTime:=dTimeT3, Procedure:="Save_order", Schedule:=False
on error goto 0
End Sub
As an example of how this is an issue:
' set this to some time in future
dTimeT1 = TimeValue("12:00:00")
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=True
' we now set a new time
dTimeT1 = TimeValue("12:05:00")
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=True
' we simulate a close of the workbook which should remove the schedule
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=false
But this code will run at 12:00 anyways because you set two schedules but only removes one.
I have a button assigned to the StopRecordingData sub to cancel both subs and it doesn't. The schedule False doesn't seem to cancel the scheduled subs in que.
Dim NextTime As Double
Sub RecordData()
Dim Interval As Double
Dim cel As Range, Capture As Range
Application.StatusBar = "Recording Started"
Set Capture = Worksheets("Dashboard").Range("C5:K5") 'Capture this row
of data
With Worksheets("Journal") 'Record the data on this worksheet
Set cel = .Range("A2") 'First timestamp goes here
Set cel = .Cells(.Rows.Count, cel.Column).End(xlUp).Offset(1, 0)
cel.Value = Now
cel.Offset(0, 1).Resize(1, Capture.Cells.Count).Value = Capture.Value
End With
NextTime = Now + TimeValue("00:01:00")
Application.OnTime NextTime, "CloseWB"
End Sub
Sub CloseWB()
Application.OnTime NextTime, "RecordData"
ThisWorkbook.Close True
End Sub
Sub StopRecordingData()
Application.StatusBar = "Recording Stopped"
Application.OnTime NextTime, "RecordData", False
Application.OnTime NextTime, "CloseWB", False
End Sub
You must either
use 2 commas in the end or
full method definition of OnTime method
as the syntax of OnTime method has 4 arguments and last 2 are optional.
Application.OnTime EarliestTime, Procedure, [LatestTime],
[Schedule]
Also, for time related variables, prefer DATE over DOUBLE. Hence use this at the top.
Dim NextTime as Date
Sub StopRecordingData()
Application.StatusBar = "Recording Stopped"
Application.OnTime NextTime, "RecordData",, False
Application.OnTime NextTime, "CloseWB",, False
End Sub
Sub StopRecordingData()
Application.StatusBar = "Recording Stopped"
Application.OnTime EarliestTime:=NextTime, Procedure:="RecordData", Schedule:=False
Application.OnTime EarliestTime:=NextTime, Procedure:="CloseWB", Schedule:=False
End Sub
I was wondering why the onTime method needs to be preceded by an on Error Resume next Statement. Obviously its because it raises an error and it doesn't seem to affect it's function but I'm just curious.
Can anybody enlighten me?
Code posted as per request!
this is in a worksheet module:
Const scrollRowName = "WindowScrollRow"
Dim ws As DataViewSheetClass
Public nextTime As Double
Public latestTime As Double
Private Sub startDog()
If Me.ProtectContents Then
nextTime = Now + TimeSerial(0, 0, 3)
If Me.ProtectContents Then Application.OnTime nextTime, Me.CodeName & ".kickDog"
End If
End Sub
Private Sub kickDog()
Static prevWsRow As Long
If Me Is ActiveSheet And Me.ProtectContents Then
wsRow = ActiveWindow.scrollRow
If wsRow <> prevWsRow Then
With Application
.screenUpdating = False
.StatusBar = "Calculating Formats"
.EnableEvents = False
scrollRow.Value2 = ActiveWindow.scrollRow
.EnableEvents = True
.StatusBar = False
prevWsRow = wsRow
.screenUpdating = True
End With
End If
Debug.Print timeStamp & ": Woof!" & Chr(9) & wsRow & Chr(9) & scrollRow.Value2
nextTime = Now + TimeSerial(0, 0, 3)
latestTime = nextTime + TimeSerial(0, 0, 10)
Application.OnTime nextTime, Me.CodeName & ".kickDog", latestTime
Else
killDog
End If
End Sub
Private Sub killDog()
On Error GoTo rebootObjects
scrollRow.Value2 = 1
On Error Resume Next
Application.OnTime nextTime, Me.CodeName & ".Worksheet_Deactivate", latestTime, False
On Error GoTo 0
Exit Sub
rebootObjects:
Set scrollRow = Me.Range(scrollRowName)
scrollRow.Value2 = 1
Resume Next
End Sub
Private Sub Worksheet_Activate()
Debug.Print timeStamp & ": " & "Summary Activate Start:" & Chr(9) & MicroTimer - t
t = MicroTimer
On Error GoTo enableAndExit
Set ws = New DataViewSheetClass
Application.EnableEvents = False
With ws
.addedActiveArea = Range("WeeksTable")
.addedActiveArea = Range("SummaryTotals")
.SparkTargetBehaviour = HEAVY
End With
enableAndExit:
Err.Clear
Application.EnableEvents = True
Set scrollRow = Me.Range(scrollRowName)
Set volatileRange = Me.Range(volatileRangeName)
startDog
Debug.Print timeStamp & ": " & "Summary Activated:" & Chr(9) & MicroTimer - t
t = MicroTimer
End Sub
Private Sub Worksheet_Deactivate()
killDog
Set ws = Nothing
End Sub
Its not required and it's a horribly hacky way to write code.
There are very few scenarios where "On Error Resume Next" is acceptable.
Here are two to consider:
Public function Example1() as Boolean
dim blnReturnValue as Boolean
On error goto errHandler
... Do stuff here that might error
... All code can error!
blnReturnValue = True ' Set return flag to success
cleanExit:
On Error Resume Next ' <-- Only Place where "On Error Resume Next" is acceptable
... Finalise things here, close objects etc.
Example1 = blnReturnValue ' Return the result
Exit Function ' Single Exit point
errHandler:
... Handle the error appropriately here
Resume CleanExit ' Ensure the function cleans up after itself
End Function
Or if you expect an error but really must continue:
Public function Example2() as Boolean
dim blnReturnValue as Boolean
On Error Goto errHandler
blnReturnValue = True ' default return flag to success
... Execute error prone code here
... This line will still run after returning from the error handler
Example2 = blnReturnValue ' Will be False if an error occurred, otherwise true
Exit Function 'Single Exit Point
errHandler:
blnReturnValue = False ' Set return flag to Failure
msgbox err.description
Resume Next ' Resume at the next line after the error occurred
End Function
I conducted a series of experiments to try to understand this function better and my results follow. I'm very pleased to confirm that the educated supposition offered by #Jean-François Corbett (here) was absolutely correct.
Yes, you can have more than one timer with the same exact same EarliestTime so this argument is NOT equivalent to "a serial number to register the timer" (contrary to my reading elsewhere).
You can have the same Procedure argument on calls with different EarliestTime arguments and it will also function normally as two separate timers.
Both of these arguments, however, must be the same as the initial call (with Schedule:=True) when killing the timer (with Schedule:=False). Failing to do so will throw ERROR: 1004: Application-defined or object-defined error on trying to execute the OnTime call with Schedule:=False. Also, the timer will not be reset in this case and an ERROR 1004: Object variable or With block variable not set will result if the call-back procedure address can not be resolved when the timer triggers.
The resolution of the timer is 1 second. If you try to start two timers 0.5 seconds apart, they will be registered with the same start time.
I don't think its wise to use the LatestTime argument: I think the timers should always be terminated manually. Omitting it also ensures that the timer will persist if there is a long save or calculate event that exceeds the timer duration and delays the call-back.
Its very important to fully qualify the call-back Procedure to ensure that it is resolvable when the timer fires. Failure to do so may result in the timer not being re-set and the workbook re-opening on attempting to close it, if other workbooks are open at the time.
It is possible to create an OnTimer Class Module with a call-back Procedure referencing a Worksheet Class Module Method. It's a good idea to ensure that the Procedure argument is fully qualified (e.g. Procedure:="'wb Name.xlsm'!Sheet1.methodName").
If you use the Worksheet_Activate and Worksheet_Deactivate events to manage the timer life-cycle and call these procedures from the Workbook_WindowActivate and Workbook_WindowDeactivate events, then the timer will start reliably and the workbook will close and stay closed. You can also use the Workbook_BeforeClose and Workbook_Open events, but they won't cover switching between Workbooks. Because of the sequence in which they fire, the window events, in conjunction with the worksheet events will cover everything.
You need to use some means of transmitting these events to the active worksheet which is hosting the timer. This can be done by creating a Class, based on CallByName to notify the ActiveSheet of the workbook events. You can also do it using a WorkBook, WithEvents Class object declared in the Worksheet, but you still need a CallByName type call to initiate on WorkBook_WindowActivate.
Attempting to kill a timer with OnTime Schedule:=False after the timer has triggered will result in ERROR: 1004: Application-defined or object-defined error.
Preceding the OnTime Schedule:=False call with On Error Resume Next allows for the possibility of killing the timer after it has triggered. I do so but I always trap errors and I have not seen any errors thrown by the OnTime function that weren't genuine and in need of handling.
In response to interest expressed by Mr #Gary's Student I include Example, working code.
In ThisWorkbook Class Module:
Option Explicit
Dim Notify As New cActiveSheetBus
'This is needed to boot the active sheet because the
'Worksheet_Activate event does not fire in the sheet
Private Sub Workbook_WindowActivate(ByVal Wn As Window)
Notify.onWindowActivate ActiveSheet
End Sub
A Class called cActiveSheetBus to provide cross-talk between the WorkBook and Worksheet Class modules:
Option Explicit
Const moduleIndent = 2
'Notify Activesheet of Workbook Events
Sub activeSheetCallBack(ws As Worksheet, cb As String)
On Error GoTo fnCallbackFailed
CallByName ws, cb, VbMethod
On Error GoTo 0
Exit Sub
fnCallbackFailed:
Debug.Print cModuleName & vbTab & myName & vbTab & "****failed****"
Err.Clear
End Sub
Public Sub onOpen(ws As Worksheet)
activeSheetCallBack ws, "onOpen"
End Sub
Public Sub beforeClose(ws As Worksheet)
activeSheetCallBack ws, "beforeClose"
End Sub
Public Sub beforeSave(ws As Worksheet)
activeSheetCallBack ws, "beforeSave"
End Sub
Public Sub afterSave(ws As Worksheet)
activeSheetCallBack ws, "afterSave"
End Sub
Public Sub onWindowActivate(ws As Worksheet)
activeSheetCallBack ws, "onWindowActivate"
End Sub
Public Sub onWindowDEActivate(ws As Worksheet)
activeSheetCallBack ws, "onWindowDEActivate"
End Sub
In the Host Worksheet's Class Module (in this case Sheet2)
Option Explicit
Const cPulseTime As Long = 1
Const cBackgroundPulse As Boolean = False
Dim mOnTime As cOnTime
'Expose custom worksheet properties to configure the timer (optional)
Property Get pulseTime() As Long
' Can put any logic here that interracts with the sheet
' or the user or the application for example
' pulseTime = cPulseTime
pulseTime = Me.Range("pulseTime")
End Property
Property Get enableBackgroundPulse() As Boolean
enableBackgroundPulse = cBackgroundPulse
End Property
Property Get designMode() As Boolean
designMode = Me.ProtectContents
End Property
'****************************************
'ActiveSheet Call-backs
Public Sub onWindowActivate()
Const cMyName As String = "onWindowActivate"
Worksheet_Activate
End Sub
'****************************************
'****************************************
'Timer call-back for cOnTime
Public Sub kickDog()
' Code to execute on timer event
'******************************************
On Error Resume Next
Me.Cells(1, 1) = Not Me.Cells(1, 1)
On Error GoTo 0
'******************************************
Debug.Print "woof!!"
On Error GoTo exitError
mOnTime.kickDog
On Error GoTo 0
Exit Sub
exitError:
End Sub
Private Sub Worksheet_Activate()
Const myName As String = "Sheet2.Worksheet_Activate"
Debug.Print myName
If (mOnTime Is Nothing) Then
Set mOnTime = New cOnTime
Else
mOnTime.kickDog
End If
End Sub
Private Sub Worksheet_Deactivate()
Const pName As String = "Sheet2.Worksheet_Deactivate"
End Sub
This in a Class Module called cOnTime:
Option Explicit
'****************************************
'Encapsulated timer that will sense the active
' sheet and expect to find a callback there
'
'In host sheet
' Const cPulseTime As Long = 1
'
' Dim mOnTime As cOnTime
' Property Get PulseTime() As Long
' PulseTime = cPulseTime
' End Property
' '****************************************
' 'Timer call-back for cOnTime
' Public Sub kickDog()
' ' Code to execute on timer event
' '******************************************
' On Error Resume Next
' Me.Cells(1, 1) = Not Me.Cells(1, 1)
' On Error GoTo 0
' '******************************************
' Debug.Print "woof!!"
' On Error GoTo exitError
' mOnTime.kickDog
' On Error GoTo 0
' Exit Sub
' exitError:
' End Sub
Const DEFDoWhen As String = "kickDog"
Const DEFPulseTime = "PulseTime"
Const DEFearliestTime As Long = 5
Const DEFlatestTime As Long = 15
Private WithEvents wb As Workbook
Private Ws As Worksheet
Private DoWhen As String
Dim KillTimer As String
Private mPulseTime As Long
Private mDesignMode
Private mBackgroundPulse
Private mNextTime As Double
Property Let callBackDoWhen(cb As String)
DoWhen = "'" & wb.Name & "'!" & Ws.CodeName & "." & cb 'e.g. 'wb Name.xlsm'!Sheet1.kickdog
End Property
Property Let callBackPulseTime(csPulseTime As String)
Const cMyName As String = "Let PulseTime"
On Error Resume Next
mPulseTime = CallByName(Ws, csPulseTime, VbGet)
If Err.Number <> 0 Then
mPulseTime = DEFearliestTime
End If
On Error GoTo 0
End Property
Private Function wsGetProperty(prop As String, default)
On Error Resume Next
wsGetProperty = CallByName(Ws, prop, VbGet)
If Err.Number <> 0 Then
wsGetProperty = default
End If
On Error GoTo 0
End Function
Private Function pulseTime() As Long
' This is a live connection to the sheet
pulseTime = wsGetProperty(DEFPulseTime, DEFearliestTime)
End Function
Private Function designMode() As Boolean
' The sheet is only consulted once
If mDesignMode = Empty Then _
mDesignMode = wsGetProperty("designMode", False)
designMode = mDesignMode
End Function
Private Function backgroundPulse() As Boolean
' The sheet is only consulted once
If mBackgroundPulse = Empty Then _
mBackgroundPulse = wsGetProperty("enableBackgroundPulse", False)
backgroundPulse = mBackgroundPulse
End Function
Public Sub kickDog()
Const myName As String = "kickDog"
Dim psMessage As String
If (Ws Is ActiveSheet Or backgroundPulse) _
And Not designMode Then
mNextTime = Now + TimeSerial(0, 0, pulseTime)
On Error Resume Next
Application.OnTime mNextTime, DoWhen
On Error GoTo 0
End If
Exit Sub
End Sub
Public Sub killDog()
If Ws Is Nothing Or mNextTime = 0 Then Exit Sub
On Error Resume Next
Application.OnTime mNextTime, DoWhen, , False
On Error GoTo 0
End Sub
Private Sub Class_Initialize()
Dim errorContext As String
Debug.Print "init conTime"
On Error GoTo enableAndExit
Set wb = ActiveWorkbook
Set Ws = ActiveSheet
On Error GoTo 0
callBackDoWhen = DEFDoWhen
callBackPulseTime = DEFPulseTime
pulseTime
designMode
backgroundPulse
kickDog
Exit Sub
enableAndExit:
If Err <> 0 Then
If Ws Is Nothing Then
errorContext = "ws"
ElseIf wb Is Nothing Then
errorContext = "wb"
End If
End If
End Sub
Private Sub Class_Terminate()
Const myName As String = "Class_Terminate"
On Error Resume Next
killDog
Set Ws = Nothing
Set wb = Nothing
Exit Sub
End Sub
' Manage the timer in response to workbook events
' If the timer is not killed it may cause the workbook
' to reopen after it is closed when the timer calls back.
Private Sub wb_WindowActivate(ByVal Wn As Window)
Const myName As String = "cOnTime.wb_WindowActivate"
Debug.Print myName
' this is handled by ThisWorkbook
End Sub
Private Sub wb_WindowDeactivate(ByVal Wn As Window)
Const myName As String = "cOnTime.wb_WindowDeactivate"
Debug.Print myName
If Not backgroundPulse Then killDog
End Sub
Private Sub wb_BeforeClose(Cancel As Boolean)
Const myName As String = "cOnTime.wb_BeforeClose"
Debug.Print myName
killDog
End Sub
Private Sub wb_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Const myName As String = "cOnTime.wb_BeforeSave"
Debug.Print myName
If SaveAsUI Then killDog
End Sub
(No actual dogs were harmed in the making of this code)