I want to make a program that runs in loop in the background and operates on refreshable query without hanging excel at the same time and when something wrong happens it displays a message. So the only idea that worked for me was scheduling a procedure with Application.Ontime - function tells itself when to run again and it stops when I toogle a slider in Excel Worksheet.
But I have a problem I can't understand: Why is this messageBox showing twice every time? 1st message tells it's (Now) time and second right after tells it is (Now+20) time.
Public Sub sendingAmessage(schTime As Date)
If Worksheets("MAIN").Range("ToggleText").Value = "MONITORING ON" Then
AppActivate Application.Caption
MsgBox (schTime)
Application.OnTime schTime, "'sendingAmessage""" & DateAdd("s", 20, Now) & "'"
End If
End Sub
Here is an example of how to re-schedule or have a recurring OnTime Event. Just see when you call a procedure you need to recall the OnTime sub from the procedure.
Public RunWhen As Double
Public Const cRunIntervalSeconds = 1
Public Const cRunWhat = "TheSub" ' the name of the procedure to run
Public Password As String
' See top of Module to see public Variable and Constants
Sub StartTimer()
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
Schedule:=True
End Sub
Sub TheSub()
' Set Cell A1 to the Current Time
ActiveSheet.Range("A1") = Time
StartTimer ' Reschedule the procedure
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
Schedule:=False
End Sub
If you also want to try out the windows API method see below: Just note that sometimes trying to cancel this is finicky. If it does save everything first and then if you close out of the workbook a process outside excel in the os will kill(forceclose) excel, as well if you call the wrong procedure as mentioned below.
' Windows Timer functions via Windows API
' PtrSafe needed for API to work
' LongPtr is safe versions for 64 and 32 bit systems
' It converts between Long and LongLong types accordingly
' Note when an incorrect pointer is listed excel will likely crash
' If error External Error-Handlers will look to OS for help and kill excel.exe
Option Explicit
Public Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal HWnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As LongPtr, _
ByVal lpTimerFunc As LongPtr) As Long
Public Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal HWnd As LongPtr, _
ByVal nIDEvent As LongPtr) As Long
Public TimerID As Long
Public TimerSeconds As Single
Public bTimerEnabled As Boolean
Public iCounter As Single
Public bComplete As Boolean
Public EventType As Integer
Sub StartTimer()
iCounter = 2
TimerID = SetTimer(0&, 0&, iCounter * 1000&, AddressOf TimerProc)
End Sub
Sub EndTimer()
KillTimer 0&, TimerID
bTimerEnabled = False
bComplete = True
End Sub
Sub TimerProc(ByVal HWnd As LongPtr, ByVal uMsg As LongPtr, _
ByVal nIDEvent As LongPtr, ByVal dwTimer As LongPtr)
Dim rc As Double
On Error Resume Next
Debug.Print iCounter
' Continue
If iCounter <= 60 Then
rc = On_Time.Range("F1045000").End(xlUp).Row + 1
On_Time.Range("F" & rc) = Time
ThisWorkbook.Save
End If
' EndTimer
If iCounter > 60 Then
EndTimer
End If
iCounter = iCounter + 1
End Sub