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

**Kramxel** · 08-29-2014, 04:34 AM

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.