+ Reply to Thread
Results 1 to 7 of 7

VBA strange behavior On time events firing at unexpected time intervals.

Hybrid View

  1. #1
    Forum Contributor
    Join Date
    09-05-2011
    Location
    Essex, England
    MS-Off Ver
    Excel 2003 Excel 2007
    Posts
    383

    VBA strange behavior On time events firing at unexpected time intervals.

    Slowly getting there with VBA but something i've (had help) written isn't behaving as it should, i'm struggling to understand why?

    THIS WORKBOOK CODE
     Option Explicit
     
    
     Private Sub Workbook_Open()
        nElapsed = TimeValue("00:14:30") '14.5 minutes
         'start a timer to countdown inactivity
        nTime = Now + nElapsed
          Application.OnTime nTime, "startCountDown"
    End Sub
     Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
          'cancel outstanding timer
        Application.OnTime nTime, "startCountDown", , False
         'any workbook activity resets the timer
        nTime = Now + nElapsed
        Application.OnTime nTime, "startCountDown"
    End Sub
    MODULE CODE
    Option Explicit
     
    Public nElapsed As Double
    Public nTime As Double
    Public NextTime As Date
    Public TimeLeft As Integer
    Sub Shutdown()
        
        endTimer
        ThisWorkbook.Save
        ThisWorkbook.Close
         
    End Sub
    
     Function RangetoHTML(rng As Range)
    
        Dim fso As Object
        Dim ts As Object
        Dim TempFile As String
        Dim TempWB As Workbook
    
        TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
        'Copy the range and create a new workbook to past the data in
        rng.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    
        'Publish the sheet to a htm file
        With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
             Source:=TempWB.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
    
        'Read all data from the htm file into RangetoHTML
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
        RangetoHTML = ts.readall
        ts.Close
        RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                              "align=left x:publishsource=")
    
        'Close TempWB
        TempWB.Close savechanges:=False
    
        'Delete the htm file we used in this function
        Kill TempFile
    
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    End Function
    Option Explicit
    
    Sub EnableActiveXCommandButtonsOnActiveSheet()
      'This is used in software development to display and activate Active X CommandButtons
    
      ActiveSheet.OLEObjects("CommandButton1").Visible = True
      ActiveSheet.OLEObjects("CommandButton1").Enabled = True
      'ActiveSheet.OLEObjects("CommandButton2").Visible = True
      'ActiveSheet.OLEObjects("CommandButton2").Enabled = True
    
    End Sub
    
    
    Sub EnableDisplayOrHideActiveXCommandButtonsOnActiveSheet()
      'This disables or hides CommandButtons when the date on the Sheet Name is more than 7 days away from today's date
      'Sheet Name format wcdd.mm.yy
      '
      'e.g. if date on Sheet is September 1, then the CommandButtons will be disabled/hidden on or after September 9
      
      Dim mySheetDate As Date
    
      Dim iDayOfMonth As Integer
      Dim iMonth As Integer
      Dim iYear As Integer
      
      Dim iDeltaDays As Long
    
      Dim sDayOfMonth As String
      Dim sMonth As String
      Dim sSheetName As String
      Dim sYear As String
      
      'Get the Name of the Active Sheet
      sSheetName = ActiveSheet.Name
      
      'Exit if the name of the Sheet is too short or too long
      If Len(sSheetName) <> Len("wcdd.mm.yy") Then
        Exit Sub
      End If
      
      '''''''''''''''''''''''''''''''''''''''
      'Get the date from the sheet
      '''''''''''''''''''''''''''''''''''''''
      
      'Get the month, day, and year as strings
      sDayOfMonth = Mid(sSheetName, 3, 2)
      sMonth = Mid(sSheetName, 6, 2)
      sYear = Mid(sSheetName, 9, 2)
      
      'Exit if the month, day, or year is not a number
      If Not IsNumeric(sDayOfMonth) Then
        Exit Sub
      End If
      If Not IsNumeric(sMonth) Then
        Exit Sub
      End If
      If Not IsNumeric(sYear) Then
        Exit Sub
      End If
      
      'Convert the strings to numbers
      iDayOfMonth = Int(sDayOfMonth)
      iMonth = Int(sMonth)
      iYear = Int(sYear) + 2000
      
      'Create the Sheet Date
      mySheetDate = DateSerial(iYear, iMonth, iDayOfMonth)
      
      'Find the number of days between the Sheet Date and today
      iDeltaDays = Date - mySheetDate
      'Debug.Print "ideltadays = " & iDeltaDays
      
      '''''''''''''''''''''''''''''''''''''''
      'Process CommandButton1
      '''''''''''''''''''''''''''''''''''''''
      
      'Make CommandButton Visible
      'Enable CommandButton
      ActiveSheet.OLEObjects("CommandButton1").Visible = True
      ActiveSheet.OLEObjects("CommandButton1").Enabled = True
    
      
      'Disable or Hide the CommandButton when the number of days is greater than or equal to 8
      If iDeltaDays >= 8 Then
      
        'Disable CommandButton
        ActiveSheet.OLEObjects("CommandButton1").Enabled = False
        
      End If
      
      '''''''''''''''''''''''''''''''''''''''
      'Process CommandButton2
      '''''''''''''''''''''''''''''''''''''''
      
      'Make CommandButton Visible
      'Enable CommandButton
      'ActiveSheet.OLEObjects("CommandButton2").Visible = True
      'ActiveSheet.OLEObjects("CommandButton2").Enabled = True
    
      
      'Disable or Hide the CommandButton when the number of days is greater than or equal to 8
      If iDeltaDays >= 8 Then
      
        'Disable CommandButton
        'ActiveSheet.OLEObjects("CommandButton2").Visible = False
        
      End If
    
    End Sub
    
    Private Sub updateTimer()
        TimeLeft = TimeLeft - 1
        If TimeLeft <= 0 Then Shutdown: Exit Sub
        With ufCheckCloseWB
        .TimeLeft = TimeLeft
        .Repaint
        DoEvents
            End With
        NextTime = Now() + TimeValue("00:00:01")
        Application.OnTime NextTime, "updateTimer"
        End Sub
    Sub endTimer()
        On Error Resume Next
        Application.OnTime NextTime, "updateTimer", , False
        On Error GoTo 0
        ufCheckCloseWB.Hide
        Timer_Refresh
        End Sub
        
    
    Sub startCountDown()
    Application.WindowState = xlMinimized
    Const ShowDurationSecs As Integer = 30
        NextTime = Now() + TimeValue("00:00:01")
        TimeLeft = ShowDurationSecs
        Application.OnTime NextTime, "updateTimer"
    
        With ufCheckCloseWB
        .TimeLeft = TimeLeft
        .Show
        End With
        End Sub
    Sub Timer_Refresh()
        nElapsed = TimeValue("00:04:30") '4.5 minutes
         'start a timer to countdown inactivity
        nTime = Now + nElapsed
        'application.OnTime ntime ""
        Application.OnTime nTime, "startCountDown"
    End Sub
    SHEET LEVEL CODE
    Option Explicit
    Sub Mail_Selection_Range_Outlook_Body()
    
        Dim rng As Range
        Dim OutApp As Object
        Dim OutMail As Object
        Dim StrBody As String
        Dim strSheetName As String
        Dim CELL As Range
        Dim strTo As String
               
        strSheetName = ActiveSheet.Name
       
        For Each CELL In ThisWorkbook.Sheets("Lookups").Range("C2:C200")
            If CELL.Value Like "?*@?*.?*" Then
                strTo = strTo & CELL.Value & ";"
            End If
        Next CELL
        If Len(strTo) > 0 Then strTo = Left(strTo, Len(strTo) - 1)
        
        Set rng = Nothing
        On Error Resume Next
        'Only the visible cells in the selection
        'Set rng = Selection.SpecialCells(xlCellTypeVisible)
        'You can also use a fixed range if you want
        Set rng = Sheets(strSheetName).Range("JN30:JU145").SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
    
        If rng Is Nothing Then
            MsgBox "The selection is not a range or the sheet is protected" & _
                   vbNewLine & "please correct and try again.", vbOKOnly
            Exit Sub
        End If
    
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
    
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        
        StrBody = "Please find below your schedule for " & strSheetName & "." & "<br>"
                  ' "Line 2" & "<br>" &
                  ' "Line 3" & "<br>"
    
        On Error Resume Next
        With OutMail
            .To = "Times Contact Centre (E-Mail)"
            .CC = strTo
            .BCC = ""
            .Subject = strSheetName & " Schedule"
            .Importance = 2
            .Recpients.Resolve
            .HTMLBody = "<P style='font-family:Calibri;font-size:12'>" & StrBody & RangetoHTML(rng)
            '.Send
            'or use
            .Display
        End With
        On Error GoTo 0
    
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    
        Set OutMail = Nothing
        Set OutApp = Nothing
    End Sub
    Function RangetoHTML(rng As Range)
    
        Dim fso As Object
        Dim ts As Object
        Dim TempFile As String
        Dim TempWB As Workbook
    
        TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
        'Copy the range and create a new workbook to past the data in
        rng.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    
        'Publish the sheet to a htm file
        With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
             Source:=TempWB.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
    
        'Read all data from the htm file into RangetoHTML
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
        RangetoHTML = ts.readall
        ts.Close
        RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                              "align=center x:publishsource=")
    
        'Close TempWB
        TempWB.Close savechanges:=False
    
        'Delete the htm file we used in this function
        Kill TempFile
    
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    End Function
    
    Private Sub Clear_Schedule_Click()
    Dim iRet As Integer
    Dim strPROMPT As String
    Dim strTITLE As String
    
    Dim screenUpdateState As String
    Dim statusBarState As String
    Dim calcState As String
    Dim eventsState As String
    Dim displayPageBreakState As String
    
    screenUpdateState = Application.ScreenUpdating
    statusBarState = Application.DisplayStatusBar
    calcState = Application.Calculation
    eventsState = Application.EnableEvents
    displayPageBreakState = ActiveSheet.DisplayPageBreaks
    
    
    strPROMPT = "Are You Sure You Want To Clear The Schedule?"
    strTITLE = "Clear Schedule?"
    iRet = MsgBox(strPROMPT, vbYesNo, strTITLE)
    If iRet = vbYes Then
    
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    
    ActiveSheet.Range("AA32:BE145").ClearContents
    ActiveSheet.Range("BK32:CO145").ClearContents
    ActiveSheet.Range("CU32:DY145").ClearContents
    ActiveSheet.Range("EE32:FI145").ClearContents
    ActiveSheet.Range("FO32:GS145").ClearContents
    ActiveSheet.Range("GY32:IC145").ClearContents
    ActiveSheet.Range("II32:JM145").ClearContents
    
    Application.ScreenUpdating = screenUpdateState
    Application.DisplayStatusBar = statusBarState
    Application.Calculation = calcState
    Application.EnableEvents = eventsState
    ActiveSheet.DisplayPageBreaks = displayPageBreakState
    
    Else
    End If
    End Sub
    
    Private Sub CommandButton1_Click()
    Dim iRet As Integer
    Dim strPROMPT As String
    Dim strTITLE As String
    
    strPROMPT = "Are You Sure You Want To Publish The Schedule?"
    strTITLE = "Publish schedule?"
    iRet = MsgBox(strPROMPT, vbYesNo, strTITLE)
    If iRet = vbNo Then
    Else
    
    Dim screenUpdateState As String
    Dim statusBarState As String
    Dim calcState As String
    Dim eventsState As String
    Dim displayPageBreakState As String
    
    screenUpdateState = Application.ScreenUpdating
    statusBarState = Application.DisplayStatusBar
    calcState = Application.Calculation
    eventsState = Application.EnableEvents
    displayPageBreakState = ActiveSheet.DisplayPageBreaks
    
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    
    Dim CELL As Range
    Dim R As Range
    Set R = ActiveSheet.Range("D32:D145")
    
    For Each CELL In R
    
            If CELL.Value = 0 Then
                    CELL.EntireRow.Hidden = True
                Else
                    CELL.EntireRow.Hidden = False
            End If
    Next CELL
    
    Call Mail_Selection_Range_Outlook_Body
    
    ActiveSheet.Rows("32:145").Hidden = False
    
    Application.ScreenUpdating = screenUpdateState
    Application.DisplayStatusBar = statusBarState
    Application.Calculation = calcState
    Application.EnableEvents = eventsState
    ActiveSheet.DisplayPageBreaks = displayPageBreakState
    
    strPROMPT = "Schedule Published Successfully!"
    strTITLE = "Success"
    iRet = MsgBox(strPROMPT, vbOKOnly, strTITLE)
    
    End If
    End Sub
    
    
    
    Private Sub Worksheet_Activate()
      Call EnableDisplayOrHideActiveXCommandButtonsOnActiveSheet
    End Sub
    EXPECTED BEHAVIOR:
    after 14 minutes and 30 seconds inactivity within the workbook a userform should pop up with a 30 second countdown asking the user if they still need the workbook open. a YES response starts a 4 minute 30 second countdown where the same userform is presented, a NO response or a timeout results in the workbook saving and closing. (need to reliably ensure this happens even if the workbook isn't the active application taking focus somehow)

    ACTUAL BEHAVIOR:
    userform is presented after a few seconds with the 30 second countdown, and re-presented a few seconds later when YES button clicked.

  2. #2
    Valued Forum Contributor
    Join Date
    09-21-2011
    Location
    Birmingham UK
    MS-Off Ver
    Excel 2003/7/10
    Posts
    2,188

    Re: VBA strange behavior On time events firing at unexpected time intervals.

    I think its the way you have your timers set up

    When you set your 15minute inactivity counter, so Now+15mins, you need to set your countdown one to but for now+14m30s, this one will just open the userform. In the userform, you'll have a cancel on the 14m30s one, and set up a new 1s timer to do the countdown.
    Hope this helps

    Sometimes its best to start at the beginning and learn VBA & Excel.

    Please dont ask me to do your work for you, I learnt from Reading books, Recording, F1 and Google and like having all of this knowledge in my head for the next time i wish to do it, or wish to tweak it.
    Available for remote consultancy work PM me

  3. #3
    Forum Contributor
    Join Date
    09-05-2011
    Location
    Essex, England
    MS-Off Ver
    Excel 2003 Excel 2007
    Posts
    383

    Re: VBA strange behavior On time events firing at unexpected time intervals.

    GRRR!!!

    I've tried implementing your idea which sounds like it should solve the problem, i think I've done it poorly as I've made the situation far far worse. (Thankfully i've the code saved here so I can fix it).

    I have the file closing itself after a few seconds or even after I press Yes in the userform (which should have given me 5 minutes).

  4. #4
    Forum Contributor
    Join Date
    09-05-2011
    Location
    Essex, England
    MS-Off Ver
    Excel 2003 Excel 2007
    Posts
    383

    Re: VBA strange behavior On time events firing at unexpected time intervals.

    I have literally spent 3 days on this and seem to only make things worse rather than better - if anyone could take a look at this and provide the code to show what i'm doing wrong - you'd be saving me one helluva migraine.

    Thank you

  5. #5
    Forum Contributor
    Join Date
    09-05-2011
    Location
    Essex, England
    MS-Off Ver
    Excel 2003 Excel 2007
    Posts
    383

    Re: VBA strange behavior On time events firing at unexpected time intervals.

    shameless bump, please help restore my sanity

  6. #6
    Valued Forum Contributor
    Join Date
    09-21-2011
    Location
    Birmingham UK
    MS-Off Ver
    Excel 2003/7/10
    Posts
    2,188

    Re: VBA strange behavior On time events firing at unexpected time intervals.

    Workbook code

    Private Sub Workbook_Open()
    
    intCountdown = 30
    
    sTimeLonger = Now + TimeValue("00:01:00")
    sTimeCountDown = Now + TimeValue("00:00:30")
    
    Application.OnTime sTimeLonger, "OneMinuteInactive", , True
    Application.OnTime sTimeCountDown, "ShowCountDown", , True
    
    End Sub
    Module code

    Public sTimeLonger As Date
    Public sTimeCountDown As Date
    Public sTimeCountDownOneSeconds As Date
    
    Public intCountdown As Integer
    
    Public Sub OneMinuteInactive()
        MsgBox "Hello"
        Application.OnTime sTimeLonger, "OneMinuteInactive", , False
    End Sub
    
    Public Sub ShowCountDown()
    
        sTimeCountDownOneSeconds = Now + TimeValue("00:00:01")
        Application.OnTime sTimeCountDownOneSeconds, "DisplayCountdown", , True
        
    End Sub
    
    Public Sub DisplayCountdown()
    
        Range("a1").Value = intCountdown
        intCountdown = intCountdown - 1
        ShowCountDown
        
    End Sub
    This is for 1minute main delay, 30 seconds for countdown. You will also need to stop the countdown when the counter gets to 0

  7. #7
    Forum Contributor
    Join Date
    09-05-2011
    Location
    Essex, England
    MS-Off Ver
    Excel 2003 Excel 2007
    Posts
    383

    Re: VBA strange behavior On time events firing at unexpected time intervals.

    worked like a charm thank you.

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. [SOLVED] Grouping events based on Time Intervals in Pivots
    By hutch2hutch in forum Excel Charting & Pivots
    Replies: 5
    Last Post: 06-13-2013, 05:10 AM
  2. [SOLVED] Time intervals SUM unexpected result
    By NunoDinis in forum Excel General
    Replies: 11
    Last Post: 06-04-2012, 12:58 PM
  3. Converting Data in Irregular Time Intervals into Regular Time Intervals
    By AlexJT in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 06-25-2011, 02:42 AM
  4. Need to Transpose Irregular Time Intervals into Regular Time Intervals
    By AlexJT in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 06-24-2011, 08:30 PM
  5. Rounding Time Intervals to the Nearest Specified Time Increment
    By ExcelTip in forum Tips and Tutorials
    Replies: 0
    Last Post: 08-23-2005, 12:21 PM

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1