I was successful in modifying your spreadsheet to allow Modifying the spreadsheet (including UNDO) without stopping the timers and without crashing Excel.
The use of formulas to implement API Timer is courtesy of Jaafar Tribak
See May 27, 2009 post #3 in https://www.mrexcel.com/board/thread...t-cell.392397/
Thank you Jaafar
Please note that 'real time' code is difficult to debug, so there may still exist some unwanted 'side effects'. Please let me know if you have any problems.
Notes:
a. Implemented two timers only - Client Tasks 1 and 2.
Multiple Timers can run simultaneously or there is a limit of one 'Active Timer' only - chosen by a PERMANENT VBA change. See Sub LogicallyStopAllTimers() for instructions.
Whether one or multiple Logical Timers, there is only one SetTimer() Timer running.
b. Sub AdjustValue() in code module ModOriginal was changed to xAdjustValue() to avoid a conflict with a modified routine in code module ModNew.
c. The remainder of Sheet2 Code module VBA was NOT changed - Reset should work exactly as before.
d. Client Timer1 and Timer2 code was commented out in Code Module ModOriginal.
e. When Deleting Sheets Runtime Error Occurs (50290 = Application-defined or object-defined error) but is trapped by the software.
How the software works:
a. One API Timer is used using API code SetTimer() and KillTimer().
SetTimer() creates a timer that repeats at a specified interval until stopper by KillTimer().
b. Your data design was left intact as much as possible. VBA code affects Sheet 'Data_tab' as follows using 'Client Timer 1' as an example:
(1) Cell X3 = No change
(2) Column W = No change
(3) Cell V3 contains the formula '=NOW() - Data_tab!U3' when Timer1 is active
(3) Cell V3 = the VALUE that was in cell V3 when STOP was Clicked
(4) CellU3 = the Baseline (when Start was Clicked) Date and Time when Timer1 is active
(4) CellU3 = BLANK when Timer1 is NOT active
c. Sub APITimerEventHandler() runs each wake cycle of the generic timer (approximately at 1 second intervals)
APITimerEventHandler() causes 'Calculate' to occur for each active timer (e.g. Cell V3 for Client Timer1.
The use of 'Calculate' instead of writing to the spreadsheet directly allows Spreadsheet changes including Adding Sheets and UNDO while the Timer is running.
It is recommended that Suspend/Resume be used when Deleting Sheets.
d. Modifying VBA while the Timer is active can cause Excel to crash. The use of the 'Suspend' and 'Resume' CommandButtons can stop this from happening.
e. Occassionally Runtime Error '50290 Application-defined or object-defined error' occurs. 'On Error Resume Next' (i.e. ignoring the error) seems to mitigate the problem.
Important code excerpts follow. See the attached file for complete code:
Option Explicit
'The use of formulas to implement API Timer is courtesy of Jaafar Tribak
'See May 27, 2009 post #3 in https://www.mrexcel.com/board/threads/problems-with-running-clock-in-worksheet-cell.392397/
'Thank you Jaafar
'NOTE: This has NOT BEEN tested using 64 bit Excel
#If VBA7 And Win64 Then
' 64 bit Excel
'The following line is supposed to be RED in 32 bit Excel
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
' 32 bit Excel
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
'NOTE: This has not been tested in 64 bit Excel
#If VBA7 And Win64 Then
'All of the Win64 lines are supposed to be RED in 32 bit Excel
' Returns an unsigned long pointer (nIDEvent) if the timer is created. Failure returns a zero.
Public Declare PtrSafe Function SetTimer _
Lib "User32.dll" _
(ByVal HWnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) _
As LongPtr
Public Declare PtrSafe Function KillTimer _
Lib "User32.dll" _
(ByVal HWnd As LongPtr, _
ByVal nIDEvent As LongPtr) _
As Long
Public lTimerIdAddress As LongPtr
#Else
' Returns an unsigned long pointer (nIDEvent) if the timer is created. Failure returns a zero.
Public Declare Function SetTimer _
Lib "User32.dll" _
(ByVal HWnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) _
As Long
Public Declare Function KillTimer _
Lib "User32.dll" _
(ByVal HWnd As Long, _
ByVal nIDEvent As Long) _
As Long
Public lTimerIdAddress As Long
#End If
Type TimerDataStructureType
sElapsedTimeCell As String
sAdjustmentCell As String
End Type
Public Const FIVE_MINUTES As Double = 5# / 86400#
Public Const sColorACTIVE = "Green"
Public Const sColorINACTIVE = "Pink"
Public Const sColorSUSPENDED = "Orange"
Public Const sApiTimerSuspendedCELL = "F17"
Public Const sActiveTimerInfoCELL = "F21"
Public Const sActiveTimerCountInfoCELL = "F22"
Public bGblAPITimerSuspended As Boolean
Public iGblActiveClientTimerCount As Long
Public Const sGblClientTimer1CELL = "I9"
Public Const sGblClientTimer2CELL = "I10"
Public Const sGblClientTimer3CELL = "I11"
Public Const sGblClientTimer4CELL = "I12"
Public Const sGblClientTimer5CELL = "I13"
Public bGblActiveClientTimer1 As Boolean
Public bGblActiveClientTimer2 As Boolean
Public bGblActiveClientTimer3 As Boolean
Public bGblActiveClientTimer4 As Boolean
Public bGblActiveClientTimer5 As Boolean
Sub StopAPITimer()
'This stops the API Timer
'Stop the Timer
KillTimer 0, lTimerIdAddress
End Sub
Sub StartAPITimer()
'This is called by the User to Start the API Timer
Const iTimerRepeatRateMILLISECONDS As Long = 1000 '1000 milliseconds = one second
'Stop the Clock if it is running
Call StopAPITimer
'This starts a timer that will repeat until stopped
lTimerIdAddress = SetTimer(0, 0, iTimerRepeatRateMILLISECONDS, AddressOf APITimerEventHandler)
End Sub
Sub SuspendAPITimer()
'This stops the API Timer
Dim track As Worksheet
Set track = ThisWorkbook.Sheets("Tracker")
If iGblActiveClientTimerCount = 0 Then
bGblAPITimerSuspended = False
MsgBox "NOTHING DONE. There are NO Active Timers."
ElseIf bGblAPITimerSuspended = True Then
MsgBox "NOTHING DONE. The API Timer is ALREADY Suspended."
Else
bGblAPITimerSuspended = True
Call StopAPITimer
Sleep 100
track.Range(sApiTimerSuspendedCELL).Value = "API Timer is Suspended"
Call ColorAllActiveTimersOnSheetTrack(sColorSUSPENDED)
End If
'Clear Object Pointers
Set track = Nothing
End Sub
Sub SuspendAPITimerNoMessages()
'This stops the API Timer with No Messages
If iGblActiveClientTimerCount = 0 Then
bGblAPITimerSuspended = False
ElseIf bGblAPITimerSuspended = True Then
'do nothing
Else
bGblAPITimerSuspended = True
Call StopAPITimer
Sleep 100
On Error Resume Next 'START HERE
If Err.Number <> 0 Then 'START HERE
Debug.Print "SuspendAPITimerNoMessages()", Err.Number, Err.Description, Now()
End If
Call ColorAllActiveTimersOnSheetTrack(sColorSUSPENDED)
End If
End Sub
Sub ResumeAPITimer()
'This is called by the User to Start the API Timer
If iGblActiveClientTimerCount = 0 Then
bGblAPITimerSuspended = False
MsgBox "NOTHING DONE. There are NO Active Timers to Resume."
ElseIf bGblAPITimerSuspended = True Then
bGblAPITimerSuspended = False
ThisWorkbook.Sheets("Tracker").Range(sApiTimerSuspendedCELL).Value = ""
Call StartAPITimer
Call ColorAllActiveTimersOnSheetTrack(sColorACTIVE)
Else
MsgBox "NOTHING DONE. The API Timer is ALREADY Active."
End If
End Sub
Sub ResumeAPITimerNoMessages()
'This is called by the User to Start the API Timer with No Messages
If iGblActiveClientTimerCount = 0 Then
bGblAPITimerSuspended = False
'MsgBox "NOTHING DONE. There are NO Active Timers to Resume."
ElseIf bGblAPITimerSuspended = True Then
bGblAPITimerSuspended = False
ThisWorkbook.Sheets("Tracker").Range(sApiTimerSuspendedCELL).Value = ""
Call StartAPITimer
Call ColorAllActiveTimersOnSheetTrack(sColorACTIVE)
Else
'MsgBox "NOTHING DONE. The API Timer is ALREADY Active."
End If
End Sub
Sub StopAllTimersAndUpdateAllTimerData()
'This Stops all Timers and makes sure all data is properly updated
Call StopTimer1
Call StopTimer2
End Sub
Sub LogicallyStopAllTimers()
'This is used to logically 'Stop All Timers' if only one Timer is allowed to Run at a time
'
'NOTE: If MORE THAN ONE time is allowed to run at a time comment out ALL the code below
'Set the CONDITIONAL COMPILATION CONSTANT below to 'True' to allow MULTIPLE SIMULTANEOUS TIMERS
'Set the CONDITIONAL COMPILATION CONSTANT below to 'False' to allow only ONE TIMER to be running
#Const ALLOW_MULTIPLE_SIMULTANEOUS_TIMERS = False
#If ALLOW_MULTIPLE_SIMULTANEOUS_TIMERS = True Then
ThisWorkbook.Sheets("Tracker").Range(sActiveTimerInfoCELL).Value = "MULTIPLE simultaneous Timers ARE ALLOWED"
#Else
Call StopAllTimersAndUpdateAllTimerData
ThisWorkbook.Sheets("Tracker").Range(sActiveTimerInfoCELL).Value = "Only One Timer is Allowed to be Running"
#End If
End Sub
Sub APITimerEventHandler()
'This processes Timer Events
Dim myCurrentDateAndTime As Date
'Debug.Print "APITimerEventHandler()", Format(Now(), "hh:mm:ss."), Timer 'Output to Immediate Window (CTRL G in the Debugger)
DoEvents
'Get the Current Date and Time
myCurrentDateAndTime = Now()
'Process Timer1
If bGblActiveClientTimer1 = True Then
'DoEvents 'Yield to other processes
On Error Resume Next 'START HERE
ThisWorkbook.Sheets("Data_Tab").Range("V3").Calculate
If Err.Number <> 0 Then
Debug.Print "APITimerEventHandler() Timer1", Err.Number, Err.Description, Now()
End If
End If
'Process Timer2
If bGblActiveClientTimer2 = True Then
'DoEvents 'Yield to other processes
On Error Resume Next 'START HERE
ThisWorkbook.Sheets("Data_Tab").Range("AA3").Calculate
If Err.Number <> 0 Then
Debug.Print "APITimerEventHandler() Timer2", Err.Number, Err.Description, Now()
End If
End If
MYEXIT:
'Resume Normal Error Processing
On Error GoTo 0
End Sub
Sub AdjustValue()
Dim track As Worksheet
Dim data As Worksheet
Dim btnName As String
Dim targetCell As String
Dim addAmount As Integer
'Suspend the API Timer with No Messages
Call SuspendAPITimerNoMessages
Set data = ThisWorkbook.Sheets("Data_tab")
Set track = ThisWorkbook.Sheets("Tracker")
If track.Range("G2").Value = "" Then
MsgBox ("Please Fill In Assignment Date in G2")
GoTo MYEXIT
Else
btnName = Application.Caller
targetCell = Mid(btnName, 5, Len(btnName))
addAmount = IIf(Left(btnName, 3) = "ADD", 1, -1)
data.Range(targetCell).Value = _
data.Range(targetCell).Value + addAmount
End If
MYEXIT:
'Resume the API Timer with No Messages
Call ResumeAPITimerNoMessages
'Clear Object pointers
Set data = Nothing
Set track = Nothing
End Sub
Additional remarks and suggestions:
a. File with passwords take a lot of extra time to debug. Do not implement passwords until debugging is completed.
b. To prevent typos from ruining days and weeks of work 'Option Explicit' is NEEDED at the top of each code module. This prevents errors caused by missspellings and FORCES every variable to be DECLARED (e.g. Dim i as Integer). https://www.excel-easy.com/vba/examp...-explicit.html
Lewis
Due to space limitations some code is continued in the next reply.
LinkBack URL
About LinkBacks
Register To Reply
below the post.
Bookmarks