Results 1 to 5 of 5

Thread: [RESOLVED] MSof10 - Application.OnTime question

  1. #1

    Thread Starter
    Addicted Member
    Join Date
    Jan 2008
    Posts
    167

    Resolved [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

  2. #2
    PowerPoster
    Join Date
    Dec 2004
    Posts
    25,618

    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

  3. #3

    Thread Starter
    Addicted Member
    Join Date
    Jan 2008
    Posts
    167

    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?

  4. #4
    PowerPoster
    Join Date
    Dec 2004
    Posts
    25,618

    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

  5. #5

    Thread Starter
    Addicted Member
    Join Date
    Jan 2008
    Posts
    167

    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
  •  



Click Here to Expand Forum to Full Width