Code Execution Degrades Over Time

[KDT]

Hello all. I signed up here to ask for some help with the code I am going to post. The code works, but I sure it is not the most efficient way to do what I am doing and there are some problems that arise after many hours of execution that have baffled me to the point I need fresh eyes and more excel knowledgeable people to look at it.

In a nutshell, this code is behind a report that has to print each morning at 7am or desired time and generate a .csv file for storage backup of the data. It is also triggering database queries once an hour for new data. I give the user input boxes to set the Print time, view minutes and seconds to next update of data, I display current time to be compared with Next Print Time and give them input boxes to give a file path where the csv file will be written. It all works fine.....for a while.

I think my problem stems from keeping the time displayed accurately in a cell for viewing and using it for the compare to know when to print and save.

What I have noticed is that the longer the code runs, the more it loads up on memory and processor time to the point it will eventually crash. I have tried to slow the code down with WAIT commands, Sleep commands and experimented with some For/While looping but all of my attempts have affected either the time updating or paused function of the spreadsheet while waiting or sleeping.

I don't do a lot of excel vba so my methodology may be laughable, but for better or worse, here it is. Any help with this will be much appreciated.

With the exception of a couple of buttons coming from Sheet1 writing to Global bits, all code is in this one module. A screenshot of the user input area is also attached. Thank you.

Global Poll_Timer As Integer
Global RunCode As Boolean
Dim Timer_Interval As Double
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub Auto_Open()
    PollTimer = 1 'On Open Start Poll Timer Counts at 1
    Call Start
End Sub

Sub Start()

Dim Interval As Double

    RunCode = True 'Set True at Startup
    Interval = CDbl(Range("L1").Value) 'Get the Interval Value (For Time Incrementing) from Cell L1
    Call Timer(Interval)
End Sub

Sub Timer(Optional ByVal Interval As Double)
    If Interval > 0 Then Timer_Interval = Interval 'Sends Interval Time from Cell L1 if > 0
    If Timer_Interval > 0 Then Application.OnTime (Now + Timer_Interval), "FcCalls" 'Update Time + 1 sec
End Sub

Sub FcCalls() 'Sub to call all System Functions
    If RunCode = True Then
    Call UpdateTime
    Call Watchdog
    Call Timer
    End If
End Sub

Sub UpdateTime()
    Sheet1.txtTime.Value = CStr(Time) 'Updates Current Time Cell
End Sub

Sub Watchdog()

Dim Poll_Timer_Countdown As Integer
Dim fPath As String
Dim fName As String
Dim fName_Print As String

    fPath = Sheet1.Range("G5") 'Get file path from Cell G5
    fName = Sheet1.Range("M6") 'Get file name from Cell M6
    strDate = Format(Date, "_mm_dd_yy") 'Append date stamp to filename for unique ID
    Sheet1.txtWritePath.Value = fPath & fName & strDate 'Update Current Save Path to Cell H3
    fName_Print = fPath & fName & strDate 'Generate file name for saving file

    Poll_Timer = Poll_Timer + 1 'Increment in seconds a poll timer for poll trigger
    Poll_Timer_Countdown = 3600 - Poll_Timer 'Reverse second output for countdown to next poll
    Sheet1.txtNextPoll.Value = Poll_Timer_Countdown 'Display poll countdown in seconds
    Sheet1.txtNextPollMin.Value = Format(Poll_Timer_Countdown / 60, "00.00") 'Display poll countdown in minutes

If Poll_Timer_Countdown < 1 Then
    Sheet1.Range("A1") = Now() 'Change value in Cell A1 to Prompt New Poll
    Poll_Timer = 1 'Resets for Next Poll
End If

If Sheet1.txtPrintTime.Value = Sheet1.txtTime.Value Then
        
    On Error GoTo PrintError

    Sheet1.PrintOut 'Print Report at Set Time
    
    On Error GoTo FileError
    
    Sleep (1000) 'Pause 1 second before continuing

    'The following code is to generate and save a csv file backup
    ChDir fPath
    Workbooks.Open Filename:=fPath & "DailyReport.csv"
    Windows("cam_report_Master.xls").Activate
    Range("B9:N66").Select
    Selection.Copy
    Windows("DailyReport.csv").Activate
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=fName_Print, _
        FileFormat:=xlCSV, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWindow.Close
    Range("A9").Select
    Application.DisplayAlerts = True
 
    '***End CSV File Code***
 

Exit Sub

PrintError: ' Error handler in event no printer is found
MsgBox "Print Error:  Check your printer, network connections."
End If

Exit Sub

FileError: ' Error handler in event no file can be generated
MsgBox "File Saving Error:  An error occured while saving the daily report file.  Check your filename and path."

End Sub

[Tom Schreiner]

Hi KD. I could not find any recursion and I was also unable to test your code. Evenso, this is worth a try as I suspect that you are stacking up calls to OnTime.

Option Explicit

Global Poll_Timer As Integer
Global RunCode As Boolean
Dim Timer_Interval As Double
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private RunNext As Date

Sub Auto_Open()
    PollTimer = 1 'On Open Start Poll Timer Counts at 1
    Call Start
End Sub

Sub Start()

Dim Interval As Double

    RunCode = True 'Set True at Startup
    Interval = CDbl(Range("L1").Value) 'Get the Interval Value (For Time Incrementing) from Cell L1
    Call Timer(Interval)
End Sub

Sub KillTimer()
    On Error Resume Next
    Application.OnTime RunNext, "FcCalls", False
End Sub

Sub Timer(Optional ByVal Interval As Double)
    KillTimer
    If Interval > 0 Then Timer_Interval = Interval 'Sends Interval Time from Cell L1 if > 0
    If Timer_Interval > 0 Then
        RunNext = (Now + Timer_Interval)
        Application.OnTime RunNext, "FcCalls" 'Update Time + 1 sec
    End If
End Sub

Sub FcCalls() 'Sub to call all System Functions
    If RunCode = True Then
    Call UpdateTime
    Call Watchdog
    Call Timer
    End If
End Sub

Sub UpdateTime()
    Sheet1.txtTime.Value = CStr(Time) 'Updates Current Time Cell
End Sub

Sub Watchdog()

Dim Poll_Timer_Countdown As Integer
Dim fPath As String
Dim fName As String
Dim fName_Print As String

    fPath = Sheet1.Range("G5") 'Get file path from Cell G5
    fName = Sheet1.Range("M6") 'Get file name from Cell M6
    strDate = Format(Date, "_mm_dd_yy") 'Append date stamp to filename for unique ID
    Sheet1.txtWritePath.Value = fPath & fName & strDate 'Update Current Save Path to Cell H3
    fName_Print = fPath & fName & strDate 'Generate file name for saving file

    Poll_Timer = Poll_Timer + 1 'Increment in seconds a poll timer for poll trigger
    Poll_Timer_Countdown = 3600 - Poll_Timer 'Reverse second output for countdown to next poll
    Sheet1.txtNextPoll.Value = Poll_Timer_Countdown 'Display poll countdown in seconds
    Sheet1.txtNextPollMin.Value = Format(Poll_Timer_Countdown / 60, "00.00") 'Display poll countdown in minutes

If Poll_Timer_Countdown < 1 Then
    Sheet1.Range("A1") = Now() 'Change value in Cell A1 to Prompt New Poll
    Poll_Timer = 1 'Resets for Next Poll
End If

If Sheet1.txtPrintTime.Value = Sheet1.txtTime.Value Then
        
    On Error GoTo PrintError

    Sheet1.PrintOut 'Print Report at Set Time
    
    On Error GoTo FileError
    
    Sleep (1000) 'Pause 1 second before continuing

    'The following code is to generate and save a csv file backup
    ChDir fPath
    Workbooks.Open Filename:=fPath & "DailyReport.csv"
    Windows("cam_report_Master.xls").Activate
    Range("B9:N66").Select
    Selection.Copy
    Windows("DailyReport.csv").Activate
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=fName_Print, _
        FileFormat:=xlCSV, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWindow.Close
    Range("A9").Select
    Application.DisplayAlerts = True
 
    '***End CSV File Code***
 

Exit Sub

PrintError: ' Error handler in event no printer is found
MsgBox "Print Error:  Check your printer, network connections."
End If

Exit Sub

FileError: ' Error handler in event no file can be generated
MsgBox "File Saving Error:  An error occured while saving the daily report file.  Check your filename and path."

End Sub

[KDT]

Thanks for the response Tom, but it does not appear to work. I copied verbatim what you had after exporting my original module and the code works but within 10 seconds it will wind up to what appears to be a somewhat infinite loop that eats about 50% of my process resources and requires an End Task to close.

I think you are right about loading up OnTime calls though. I just don't understand how to clear them between calls and I think that is what you are trying to do, but I will admit that don't completely understand you code does to unload the calls.

Thanks

[KDT]

Tom I kept playing with the code and reading to see what you were doing with it and I stumbled onto the fix of what you posted. Basically adding the Schedule:=True/False to your code, it is working with no wind up. I notice my Mem Usage on Excel dropped 12mb as well. Processor load is mostly 0 bouncing to 1 occasionally. I am going to let this run and I will know by tomorrow if this was the fix. Thanks again.

Sub KillTimer()
    On Error Resume Next
    Application.OnTime RunNext, "FcCalls", Schedule:=False
End Sub

Sub Timer(Optional ByVal Interval As Double)
    KillTimer
    If Interval > 0 Then Timer_Interval = Interval 'Sends Interval Time from Cell L1 if > 0
    If Timer_Interval > 0 Then
        RunNext = (Now + Timer_Interval)
        Application.OnTime RunNext, "FcCalls", Schedule:=True 'Update Time + 1 sec
    End If
End Sub

[Tom Schreiner]

ERROR: Application.OnTime RunNext, "FcCalls", False
CORRECT: Application.OnTime RunNext, "FcCalls", , False

Yes. An error on my part. I passed the argument incorrectly. It wouldn't be the first time that I've blown up Excel with a comma or a period.

I'm glad you figured it out as I may have never noticed...

[KDT]

The code above seems to have fixed the problem with the CPU getting loaded up. It has now been running some 20 hours without locking up. But I have been watching my Memory Usage in Task Manager and from 3pm yesterday until now, it has risen from 22 mb (on startup of the app) to 96 mb as of the time of this post. I know this is still stemming from the time display I am doing. I have removed all calls and experimented to see what the mem usage does and it only ratchets up when the time functions are being used. With the fix from above it has extended the run time of this but at the rate the mem usage is going up, it will surely run my pc out of memory within 3 or 4 days.

This is the code that is being used for time and apparently causing the memory load. I re-ordered things a little and remove some junk that I really didn't need.

Are there any other things that can be done to unload memory usage.

Sub Auto_Open()
    Poll_Timer = 1 'On Open Start Poll Timer Counts at 1
    Call Start
End Sub

Sub Start()
    RunCode = True 'Set True at Startup
    Call Timer
End Sub

Sub KillTimer()
    On Error Resume Next
    Application.OnTime Now + TimeValue("00:00:01"), "FcCalls", ,False
    Call Timer
End Sub

Sub Timer()
    Application.OnTime Now + TimeValue("00:00:01"), "FcCalls"
End Sub

Sub FcCalls() 'Sub to call all System Functions
    If RunCode = True Then
    Call UpdateTime
    Call Watchdog
    Call KillTimer
    End If
End Sub

Sub UpdateTime()
    Sheet1.txtTime.Value = CStr(Time) 'Updates Current Time Cell
End Sub