Sheets not changing to Very hidden when timer runs out

**Nitro2481** · 03-08-2016, 09:05 AM

Hi Guys,

I have this code in my "This workbook"

Option Explicit
Option Compare Text
Dim ws As Worksheet
Const MaxUses As Long = 5   '<- change uses
Const wsWarningSheet As String = "Splash"

Private Type mySheetVisibilityStructure
  sSheetName As String
  iVisibility As Long
End Type

Private bGblDoNotCancelIfCalledFromCloseEvent As Boolean

Const sSheetNameThatMUST_REMAIN_VISIBLE = "Splash"
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

  Dim wks As Worksheet
  Dim mySheetVisibilityStructureArray() As mySheetVisibilityStructure
  Dim i As Long
  Dim iVisibility As Long
  Dim iVisibilityErrorSheet As Long
  Dim sActiveSheetName As String
  Dim sErrorSheetName As String
  Dim sSheetName As String
  
  'Initialize the 'Sheet Visibiilty Structure Array'
  ReDim mySheetVisibilityStructureArray(1 To 1)
  
  'Save the 'Active Sheet' Name
  sActiveSheetName = ActiveSheet.Name
  
  'Verify that the 'Master Sheet' exists
  On Error Resume Next
  iVisibility = Sheets(sSheetNameThatMUST_REMAIN_VISIBLE).Visible
  If Err.Number <> 0 Then
    Err.Clear
    MsgBox "SAVE NOT DONE.  Data Integrity Error." & vbCrLf & _
           "In order to save this file Sheet '" & sSheetNameThatMUST_REMAIN_VISIBLE & "' MUST EXIST." & vbCrLf & vbCrLf & _
           "WARNING.  If this condition is NOT CORRECTED, Data may be LOST."
    Cancel = True   'Cancel Save
    On Error GoTo 0
    Exit Sub
  End If
  On Error GoTo 0
  
  'Disable 'Screen Updating' to eliminate Screen Flicker
  Application.ScreenUpdating = False
  
  'Save the 'Visibility of Each Sheet'
  'Make all Sheets Hidden Except the 'Master Sheet'
  For Each wks In ThisWorkbook.Sheets
      'Add an element to the 'Sheet Visibiilty Structure Array'
      'Put the 'Sheet Name' and the 'Sheet Visibility' in the Array
      i = i + 1
      ReDim Preserve mySheetVisibilityStructureArray(1 To i)
      mySheetVisibilityStructureArray(i).sSheetName = wks.Name
      mySheetVisibilityStructureArray(i).iVisibility = wks.Visible
      
    'Make the 'Master Sheet' visible and the Active Sheet
    'Hide All other Sheets
    If UCase(wks.Name) = UCase(sSheetNameThatMUST_REMAIN_VISIBLE) Then
      'Make the 'Master Sheet' visible and make the 'Master Sheet' the 'Active Sheet'
      wks.Visible = xlSheetVisible
      wks.Activate
    Else
      'Hide all other Sheets
      wks.Visible = xlSheetVeryHidden  'Can be 'xlSheetHidden' or 'xlSheetVeryHidden'
    End If
  
  Next wks
  
  'Turn Off Excel Events
  Application.EnableEvents = False
  

  'Save this file
  ThisWorkbook.Save
  
'Cancel command removed from here and moved to the bottom of the routine


  'Restore Original Sheet Visibility
  For i = LBound(mySheetVisibilityStructureArray) To UBound(mySheetVisibilityStructureArray)
    sSheetName = mySheetVisibilityStructureArray(i).sSheetName
    iVisibility = mySheetVisibilityStructureArray(i).iVisibility
    
    'A runtime error will occur if Excel attempt to hide all Sheets
    On Error Resume Next
    Sheets(sSheetName).Visible = iVisibility
    If Err.Number = 1004 Then
      Err.Clear
      sErrorSheetName = sSheetName
      iVisibilityErrorSheet = iVisibility
    End If
    On Error GoTo 0
  Next i
  
  'If a Sheet had a runtime error - restore it's original visibility
  If Len(sErrorSheetName) > 0 Then
    Sheets(sErrorSheetName).Visible = iVisibilityErrorSheet
  End If
  
  'Resume with the 'Original Active Sheet'
  Sheets(sActiveSheetName).Activate
  
  'Turn On Excel Events
  'Turn On Screen Updating
  Application.EnableEvents = True
  Application.ScreenUpdating = True


 'Reset Iterations in an attempt to prevent 'Circular Reference' Error
  Application.Iteration = True
  Application.MaxIterations = 1
  Application.MaxChange = 0.001

    ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
    
  
  'Cancel Save - to prevent recursion
  If bGblDoNotCancelIfCalledFromCloseEvent = True Then
    'Do nothing - Prevent Cancel
  ElseIf SaveAsUI = True Then
    'Do nothing - Prevent Cancel - Allow Save As Dialog Box
  Else
    Cancel = True
  End If
  
  'Reset the Global Called From Save Event Flag
  bGblDoNotCancelIfCalledFromCloseEvent = False
End Sub
Public Sub MakeAllSheetsVisible()
  Dim wks As Worksheet
  For Each wks In ThisWorkbook.Sheets
    wks.Visible = xlSheetVisible
  Next wks
End Sub

Private Sub Workbook_Open()
  For Each ws In ThisWorkbook.Sheets
        If ws.Name = wsWarningSheet Then
            ws.Visible = True
        Else
            ws.Visible = xlVeryHidden
        End If
    Next
    
    'record opening in remote cell
    With Sheets(wsWarningSheet).Cells(Rows.Count, Columns.Count)
      
    End With

Const sHide2 As String = "AA:AA, Ak:Ak, Ap:Ap, AQ:AQ, Av:Av, Aw:Aw, Bb:Bb, Bc:Bc, Bh:Bh, Bi:Bi, Bn:Bn, Bo:Bo, Bt:Bt, Bu:Bu, Bz:Bz, ca:ca "
Const sHide4 As String = "I:I, O:O"
Const sHide5 As String = "i:i, n:n"

With Sheet2
    Application.EnableEvents = False
    .Cells(1, 36).ClearContents
    Application.EnableEvents = True
    .Unprotect
    '.Range(sHide2 & 1).EntireColumn.Hidden = True
    .Range(sHide2).EntireColumn.Hidden = True
    .Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    .EnableSelection = xlUnlockedCells
End With

With Sheet4
    Application.EnableEvents = False
    .Cells(2, 16).ClearContents
    Application.EnableEvents = True
    .Unprotect
    '.Range(sHide2 & 1).EntireColumn.Hidden = True
    .Range(sHide2).EntireColumn.Hidden = True
    .Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    .EnableSelection = xlUnlockedCells
End With

With Sheet5
    Application.EnableEvents = False
    .Cells(1, 17).ClearContents
    Application.EnableEvents = True
    .Unprotect
    '.Range(sHide2 & 1).EntireColumn.Hidden = True
    .Range(sHide2).EntireColumn.Hidden = True
    .Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    .EnableSelection = xlUnlockedCells
End With

     UserForm1.Show

  'Enable Timers on Workbook Open
  bGblInhibitTimers = False

  'Stop all timers
  On Error Resume Next
  Application.OnTime RunWhen, "SaveAndClose", , False
  Application.OnTime RunStatusBarWhen, "TimeTilExitTimer", , False
  On Error GoTo 0
 
  'Arm Timer to save and close workbook
  RunWhen = Now + TimeSerial(0, NUM_MINUTES, NUM_SECONDS)
  Application.OnTime RunWhen, "SaveAndClose", , True

  'Arm Timer to display time remaining
  RunStatusBarWhen = Now + TimeSerial(0, 0, STATUS_BAR_REFRESH_TIME_IN_SECONDS)
  Application.OnTime RunStatusBarWhen, "TimeTilExitTimer", , True

 Application.Iteration = True
  Application.MaxIterations = 1
  Application.MaxChange = 0.001
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    On Error Resume Next
    Application.OnTime RunWhen, "SaveAndClose", , False
    On Error GoTo 0
    
    'Display Time Remaining Only When timers are enabled
    If bGblInhibitTimers = False Then
      RunWhen = Now + TimeSerial(0, NUM_MINUTES, NUM_SECONDS)
      Application.OnTime RunWhen, "SaveAndClose", , True
    End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
    ByVal Target As Range)

    On Error Resume Next
    Application.OnTime RunWhen, "SaveAndClose", , False
    
    On Error GoTo 0
    'Display Time Remaining Only When timers are enabled
    If bGblInhibitTimers = False Then
      RunWhen = Now + TimeSerial(0, NUM_MINUTES, NUM_SECONDS)
      Application.OnTime RunWhen, "SaveAndClose", , True
    End If

End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)

' Hide all sheets except the splash sheet
SHideAllSheets

'Stop all timers
  On Error Resume Next
  Application.OnTime RunWhen, "SaveAndClose", , False
  Application.OnTime RunStatusBarWhen, "TimeTilExitTimer", , False
  On Error GoTo 0
  
  'Disable 'Save Cancel' if Called from Here
  bGblDoNotCancelIfCalledFromCloseEvent = True

  'Clear the Status Bar
  Application.StatusBar = ""
'Sheet16.Visible = True    ' redundant
'Sheet16.Select               ' redundant

End Sub


Sub SHideAllSheets()

Dim ws As Worksheet
' global constant
' Const wsWarningSheet As String = "Splash"

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

For Each ws In ThisWorkbook.Sheets
    If ws.Name = wsWarningSheet Then
        ws.Visible = True
    Else
        ws.Visible = xlVeryHidden
    End If
Next

ThisWorkbook.Save

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

Sheet16.Visible = True
Sheet16.Select
End Sub

This changes all sheets from very hidden to visable and when closing back to very hidden again. This stops sheets from being visible if there is a macro error when the sheet is starting up. This works perfect.

I also have a timer set up that if there is no activity in 10 minutes the workbook auto closes. When this happens the sheets do not change to very hidden therefore and macro errors going forward display all sheets which I really do not want.

Option Explicit
'Module1
Public bGblInhibitTimers As Boolean
Public RunWhen As Double
Public RunStatusBarWhen As Double
Public Const NUM_MINUTES = 10
Public Const NUM_SECONDS = 0
Public Const STATUS_BAR_REFRESH_TIME_IN_SECONDS = 1

Public Sub StopTimers()
  'This is used for debugging purposes to shut down the timers

  bGblInhibitTimers = True
  On Error Resume Next
  Application.OnTime RunWhen, "SaveAndClose", , False
  Application.OnTime RunStatusBarWhen, "TimeTilExitTimer", , False
  On Error GoTo 0
 
  Application.StatusBar = "Timers stopped by StopTimers()."


End Sub

Public Sub SaveAndClose()

  'Tell the time remaining timer to stop
  bGblInhibitTimers = True
  
  On Error Resume Next
  Application.OnTime RunStatusBarWhen, "TimeTilExitTimer", , False
  On Error GoTo 0
  'Debug.Print "bGblInhibitTimers = true in SaveAndClose() at " & Now
  
  'Return control of the Status Bar to Excel
  Application.StatusBar = ""
  Application.StatusBar = False
   
  ThisWorkbook.Close savechanges:=True
End Sub

Sub TestTime()
  RunWhen = Now + TimeSerial(0, NUM_MINUTES, NUM_SECONDS)
  Debug.Print Format(RunWhen, "mm/dd/yy hh:mm:ss AM/PM")
End Sub
Sub TimeTilExitTimer()
  'This displays a time until exit message

  Const SECONDS_PER_DAY = 86400#
  Const SECONDS_PER_MINUTE = 60#
  
  Dim sMessage As String
  Dim ySecondsTimeToExit As Double
  Dim yMinutes As Double
  Dim ySeconds As Double

  Dim myTime As Date
  
  'Get the current date and time
  myTime = Now()
  
  'Calculate the number of seconds remaining to shut down
  ySecondsTimeToExit = SECONDS_PER_DAY * (RunWhen - myTime)
  
  'Check for Integrity Error - RunWhen = 0
  'Should Never Happen - Shut Down the refresh timer
  If ySecondsTimeToExit < 0 Then
    bGblInhibitTimers = True
    Application.StatusBar = "Software Integrity Error - Time Remaining Display discontinued."
  End If
  
  If ySecondsTimeToExit <= 99 Then
    sMessage = "Program will time out and exit in " & Format(ySecondsTimeToExit, "0") & " Seconds."
  Else
    yMinutes = Int(ySecondsTimeToExit / SECONDS_PER_MINUTE)
    ySeconds = Int(ySecondsTimeToExit - 60 * yMinutes)
    If yMinutes > 0 And ySeconds >= 60 Then
      yMinutes = yMinutes + 1
      ySeconds = ySeconds - 60
    End If
    
    sMessage = "Program will time out and exit at " & Format(RunWhen, "hh:mm:ss AM/PM") & " in " & _
                Format(yMinutes, "0") & " Minutes " & Format(ySeconds, "0") & " Seconds."
  End If
  
  
  If bGblInhibitTimers = True Then
    'Return control of the Status Bar to Excel
    Application.StatusBar = ""
    Application.StatusBar = False
    'Debug.Print "bGblInhibitTimers = true in TimeTilExitTimer() at " & Now

  Else
    Application.DisplayStatusBar = True
    Application.StatusBar = sMessage

    RunStatusBarWhen = Now + TimeSerial(0, 0, STATUS_BAR_REFRESH_TIME_IN_SECONDS)
    Application.OnTime RunStatusBarWhen, "TimeTilExitTimer", , True
    'Debug.Print "bGblInhibitTimers = false in TimeTilExitTimer() at " & Now
  End If

End Sub

I'm assuming I also need a "change all sheets to very hidden on close" code in the timer section but not sure how I would go about that.

**6StringJazzer** · 03-08-2016, 10:47 AM

I understand conceptually what you are trying to do but the code seems rather complex. Perhaps that's the way it needs to be; you have obviously spent quite a bit of time building this

When the file closes as a result of a ThisWorkbook.Close call from the timer expiration, the Workbook_BeforeClose event should fire, just as if the user closed it. Are you saying that doesn't happen? Have you tried stepping through with the debugger from the point of that call?

I'm not sure what setup needs to happen in the workbook for this code to work. Rather than trying to replicate your file using the right sheet names, etc., can you just attach it? It looks like this code does not deal with data so if the data is private you can simply delete the data before posting.

**Nitro2481** · 03-08-2016, 11:53 AM

Hi 6StringJazzer

Yes you are right, I have worked on this workbook and built it up over a couple of years now adding bits as I go. I would not be very strong on VBA so most of what I have done is with the help of people like yourself. I'm not sure how the debugger works?

I have manually set all sheets bar Splash to very hidden. If you close this with the x on top and try to open the spreadsheet with macros on high you get a warning with only the splash sheet visable. If the timer runs out (for this example I have set the timer at 1 min)and the sheet closes and you reopen with macros set to high you get the same warning message buit all sheets are visible and accessable. Although I am aware that Excel is not secure I am more worried about someone stumbling across this information as opposed to being malicious. I have attached the spreadsheet. If you select user name: John and password: Test

Thank you