-
Aug 23rd, 2016, 05:46 AM
#1
Thread Starter
Addicted Member
[RESOLVED] MSof10 - Application.OnTime question
Hi Guys,
I have a question on how to best use the Application.OnTime function.
Currently I have written some code below that I can start and it will continue running all day every day and execute certain commands based on different criteria, my code is below.
My issue is that randomly at certain times of the early hours of the morning, the servers that my code is checking drops out and my code bugs out unexpectedly and I only get to see this the following day.
Is there a way that I could get the code routine to run continuously but only execute the actions after a certain time each day when I know that the servers will be more continuous in their operation.
So for example, the Code will run continuously each day, and check the Date and Time, if the date is not a weekend, and the Time is after a specific time then the rest of the code will execute, but it will not execute before this time.
I hope this makes sense, I have tried using a Boolean control to switch the Timer code on and off, but once Off it doesn't run again so I have opted to run it continuously..
My Code;
Code:
Option Explicit
Dim KeepRunning As Boolean
Dim BookRunning As Boolean
Sub ScheduleMacroStart()
Debug.Print "started running Emails -- " & Now
KeepRunning = True
Application.OnTime Date + TimeValue("08:07"), "allemailsandcompile"
End Sub
'remove macro from schedule
Sub ScheduleMacroEnd()
'KeepRunning = False
End Sub
Sub allemailsandcompile() ' checks to see if all the emails have been captured
Dim pdat As Date, Monday As String, pdat2 As Date, Count As Long
Dim Saturday As Date, Sunday As Date
If Not KeepRunning Then Exit Sub '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Application.OnTime Now + TimeValue("00:20:00"), "allemailsandcompile"
pdat = Format(Now, "dd/mm/yyyy")
Debug.Print "still running -- " & Now & "--" & pdat
Monday = DateAdd("ww", -1, pdat - (Weekday(pdat, vbMonday) - 8))
Saturday = DateAdd("ww", -1, pdat - (Weekday(pdat, vbSaturday) - 8))
Sunday = DateAdd("ww", -1, pdat - (Weekday(pdat, vbSunday) - 8))
If pdat = Monday Then pdat2 = Format(Now - 3, "dd/mm/yyyy") Else pdat2 = Format(Now - 1, "dd/mm/yyyy")
If pdat = Saturday Then GoTo Weekend Else
If pdat = Sunday Then GoTo Weekend Else
On Error Resume Next
Count = 0
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Warehouse Location Summary - Wellmans.csv", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call Locations_Wellmans
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Warehouse Location Summary - Harlow.csv", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call Locations_Harlow
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Warehouse Location Summary - Northampton.csv", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call Locations_Northampton
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Warehouse Location Summary - Springvale.csv", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call Locations_Springvale
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Orders Outstanding With Multi.xlsx", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call Orders_Multi
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(Monday, "dd.mm.yyyy") & " Automated Stock Ledger By Dept.xlsx", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call stockledger
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Store Availability Measurement by SKU.xlsx", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call SkuAvailability
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Store Availability Measurement by Store.xlsx", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call storeavailability
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " SKU Range Daily Availability Summary.pdf", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call dailyrangesummary
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Essentials Overstock " & Format(pdat, "dd.mm.yyyy") & ".xlsx", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call awrreports
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Essentials at Risk " & Format(pdat, "dd.mm.yyyy") & ".xlsm", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call awrreports
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " SKU Range Daily Availability.xlsx", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call skurangefullversion
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " SKU Range Daily Availability.xlsx", vbDirectory) = vbNullString Then
Call Update_Availability
If pdat <> Saturday Then
If pdat <> Sunday Then
Call Demographics
Call Demographics_Retail
Call Demographics_Distribution
Call Non_Ranged
Call Category_Split
Call Makeup_Gallery
Call Aged_Stock
Else
End If
Else
End If
Else
End If
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Booking Detail Report.xlsx", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call Bookings
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Supplier to DC Delivery Issues " & Format(pdat2, "ddmmyy") & ".xlsx", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call dcfaileddelivery
End If
If Not Dir("I:\H925 Trading Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Slots Report.xlsx", vbDirectory) = vbNullString Then
Count = Count + 1
Else
Call Slots
End If
If Count = 15 Then
Debug.Print "All mails compiled -- " & Now & "--" & pdat
' Call ScheduleMacroEnd
Else
End If
On Error GoTo 0
Exit Sub
Weekend:
Debug.Print "Weekend - No Running"
End Sub
-
Aug 23rd, 2016, 06:00 AM
#2
Re: MSof10 - Application.OnTime question
you could try like
Code:
If Not KeepRunning Then Exit Sub '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Application.OnTime Now + TimeValue("00:20:00"), "allemailsandcompile"
if time < somepmvalue and time > someamvalue then
'all your code
end if
adjust to suit
without knowing what else you are doing, i would consider using an API timer instead of application.ontime
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Aug 23rd, 2016, 06:40 AM
#3
Thread Starter
Addicted Member
Re: MSof10 - Application.OnTime question
WestConn,
Thank you for your input and code.
Can you please tell me what an API timer is and how do I use it?
-
Aug 23rd, 2016, 07:32 AM
#4
Re: MSof10 - Application.OnTime question
Can you please tell me what an API timer is and how do I use it?
here is an example, you can modify it to do many things
in a module
Code:
Public Declare Function SetTimer Lib "user32" ( _
ByVal HWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" ( _
ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
Public TimerID As Long, timerseconds As Single, tim As Boolean
Dim Counter As Long
Dim countdown As Double
Dim txt As String
'~~> Start Timer
Sub StartTimer(timerseconds As Long)
'~~ Set the timer for 1 second
countdown = TimeSerial(0, 2, 0) 'duration 2 mins
' TimerSeconds = 1
TimerID = SetTimer(0&, 0&, timerseconds * 1000&, AddressOf TimerProc)
' txt = Sheets("sheet1").Cells(3, 3)
End Sub
'~~> End Timer
Sub EndTimer()
On Error Resume Next
KillTimer 0&, TimerID
Sheets("sheet1").Cells(3, 3) = txt
End Sub
Sub TimerProc(ByVal HWnd As Long, ByVal uMsg As Long, _
ByVal nIDEvent As Long, ByVal dwTimer As Long)
'~~> Update value in Sheet 1
Unload myform
'' Static t As Long
'' countdown = countdown - TimeSerial(0, 0, 1)
'' Sheets("sheet1").Cells(3, 3).Value = Mid(txt, t)
'' t = t + 2
'' If t > Len(txt) - 5 Then t = 0
' Debug.Print Format(countdown, "nn:ss")
' If countdown < TimeSerial(0, 0, 0) Then EndTimer
End Sub
you can call call some other procedure, from the timerproc
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Aug 23rd, 2016, 09:00 AM
#5
Thread Starter
Addicted Member
Re: MSof10 - Application.OnTime question
Westconn,
Thank you for your help buddy, I have incorporated the first part of your suggestion using the Time function and it works well.
Thanks again.
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|