Macro help - "Force Use Macro's" plus "Auto Terminate"

zakasnak

zakasnak

Active Member
Joined
Sep 21, 2005
Messages
308
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
  2. MacOS
I found this code at vbaexpress & it works as expected.

Code: 
Option Explicit 
 
Const WelcomePage = "Macros" 
 
Private Sub Workbook_BeforeClose(Cancel As Boolean) 
     'Turn off events to prevent unwanted loops
    Application.EnableEvents = False 
 
     'Evaluate if workbook is saved and emulate default propmts
    With ThisWorkbook 
        If Not .Saved Then 
            Select Case MsgBox("Do you want to save the changes you made to '" & .Name & "'?", _ 
                vbYesNoCancel + vbExclamation) 
            Case Is = vbYes 
                 'Call customized save routine
                Call CustomSave 
            Case Is = vbNo 
                 'Do not save
            Case Is = vbCancel 
                 'Set up procedure to cancel close
                Cancel = True 
            End Select 
        End If 
 
         'If Cancel was clicked, turn events back on and cancel close,
         'otherwise close the workbook without saving further changes
        If Not Cancel = True Then 
            .Saved = True 
            Application.EnableEvents = True 
            .Close savechanges:=False 
        Else 
            Application.EnableEvents = True 
        End If 
    End With 
End Sub 
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) 
     'Turn off events to prevent unwanted loops
    Application.EnableEvents = False 
 
     'Call customized save routine and set workbook's saved property to true
     '(To cancel regular saving)
    Call CustomSave(SaveAsUI) 
    Cancel = True 
 
     'Turn events back on an set saved property to true
    Application.EnableEvents = True 
    ThisWorkbook.Saved = True 
End Sub 
 
Private Sub Workbook_Open() 
     'Unhide all worksheets
    Application.ScreenUpdating = False 
    Call ShowAllSheets 
    Application.ScreenUpdating = True 
End Sub 
 
Private Sub CustomSave(Optional SaveAs As Boolean) 
    Dim ws As Worksheet, aWs As Worksheet, newFname As String 
     'Turn off screen flashing
    Application.ScreenUpdating = False 
 
     'Record active worksheet
    Set aWs = ActiveSheet 
 
     'Hide all sheets
    Call HideAllSheets 
 
     'Save workbook directly or prompt for saveas filename
    If SaveAs = True Then 
        newFname = Application.GetSaveAsFilename( _ 
        fileFilter:="Excel Files (*.xls), *.xls") 
        If Not newFname = "False" Then ThisWorkbook.SaveAs newFname 
    Else 
        ThisWorkbook.Save 
    End If 
 
     'Restore file to where user was
    Call ShowAllSheets 
    aWs.Activate 
 
     'Restore screen updates
    Application.ScreenUpdating = True 
End Sub 
 
Private Sub HideAllSheets() 
     'Hide all worksheets except the macro welcome page
    Dim ws As Worksheet 
 
    Worksheets(WelcomePage).Visible = xlSheetVisible 
 
    For Each ws In ThisWorkbook.Worksheets 
        If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden 
    Next ws 
 
    Worksheets(WelcomePage).Activate 
End Sub 
 
Private Sub ShowAllSheets() 
     'Show all worksheets except the macro welcome page
 
    Dim ws As Worksheet 
 
    For Each ws In ThisWorkbook.Worksheets 
        If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible 
    Next ws 
 
    Worksheets(WelcomePage).Visible = xlSheetVeryHidden 
End Sub

What I would like to do is incorporate a timer code so that the workbook will auto close if the user leaves it open past their allotted time to work (2 hours or so). This is to keep one user from not allowing other workers access to the workbook.

Here is my timer code in ThisWorkbook :
Code: 
Private Sub Workbook_Open()
dTime = Now + TimeValue("02:15:00")
Application.OnTime dTime, "MyMacro"
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If dTime > Now Then Application.OnTime dTime, "MyMacro", , False
End Sub

Then my code in a regular module in the workbook :
Code: 
Public dTime As Date
Sub MyMacro()
ThisWorkbook.Close savechanges:=False
End Sub

Can anyone help me put these two codes together?

Peter (VoG) helped me with the timer code (http://www.mrexcel.com/forum/showthread.php?p=2533065#post2533065)
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Sort by date Sort by votes
I assume that I can only have one Workbook_Open & one Workbook_Close event in the ThisWorkbook module.
 
Upvote 0
This works! ... with one exception... I don't want it to ask to save changes, I just want the macro to save the changes & close the file.

I assume that I need to change something in the highlighted section?

Code: 
Option Explicit
 
Const WelcomePage = "Macros"
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
     'Turn off events to prevent unwanted loops
    Application.EnableEvents = False
 
[COLOR=blue]  'Evaluate if workbook is saved and emulate default prompts[/COLOR]
[COLOR=blue] With ThisWorkbook[/COLOR]
[COLOR=blue]     If Not .Saved Then[/COLOR]
[COLOR=blue]         Select Case MsgBox("Do you want to save the changes you made to '" & .Name & "'?", _[/COLOR]
[COLOR=blue]             vbYesNoCancel + vbExclamation)[/COLOR]
[COLOR=blue]         Case Is = vbYes[/COLOR]
[COLOR=blue]              'Call customized save routine[/COLOR]
[COLOR=blue]             Call CustomSave[/COLOR]
[COLOR=blue]         Case Is = vbNo[/COLOR]
[COLOR=blue]              'Do not save[/COLOR]
[COLOR=blue]         Case Is = vbCancel[/COLOR]
[COLOR=blue]              'Set up procedure to cancel close[/COLOR]
[COLOR=blue]             Cancel = True[/COLOR]
[COLOR=blue]         End Select[/COLOR]
[COLOR=blue]      End If[/COLOR]
 
         'If Cancel was clicked, turn events back on and cancel close,
         'otherwise close the workbook without saving further changes
        If Not Cancel = True Then
            .Saved = True
            Application.EnableEvents = True
[COLOR=magenta]          .Close savechanges:=False[/COLOR]
        Else
            Application.EnableEvents = True
        End If
    End With
    On Error Resume Next
    Application.OnTime RunWhen, "SaveAndClose", , False
    On Error GoTo 0
End Sub
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
     'Turn off events to prevent unwanted loops
    Application.EnableEvents = False
 
     'Call customized save routine and set workbook's saved property to true
     '(To cancel regular saving)
    Call CustomSave(SaveAsUI)
    Cancel = True
 
     'Turn events back on an set saved property to true
    Application.EnableEvents = True
    ThisWorkbook.Saved = True
End Sub
 
Private Sub Workbook_Open()
     'Unhide all worksheets
    Application.ScreenUpdating = False
    Call ShowAllSheets
    Application.ScreenUpdating = True
     'Start timer
    On Error Resume Next
    Application.OnTime RunWhen, "SaveAndClose", , False
    On Error GoTo 0
    RunWhen = Now + TimeSerial(0, NUM_MINUTES, 0)
    Application.OnTime RunWhen, "SaveAndClose", , True
End Sub
Private Sub CustomSave(Optional SaveAs As Boolean)
    Dim ws As Worksheet, aWs As Worksheet, newFname As String
     'Turn off screen flashing
    Application.ScreenUpdating = False
 
     'Record active worksheet
    Set aWs = ActiveSheet
 
     'Hide all sheets
    Call HideAllSheets
 
     'Save workbook directly or prompt for saveas filename
    If SaveAs = True Then
        newFname = Application.GetSaveAsFilename( _
        fileFilter:="Excel Files (*.xls), *.xls")
        If Not newFname = "False" Then ThisWorkbook.SaveAs newFname
    Else
        ThisWorkbook.Save
    End If
 
     'Restore file to where user was
    Call ShowAllSheets
    aWs.Activate
 
     'Restore screen updates
    Application.ScreenUpdating = True
End Sub
 
Private Sub HideAllSheets()
     'Hide all worksheets except the macro welcome page
    Dim ws As Worksheet
 
    Worksheets(WelcomePage).Visible = xlSheetVisible
 
    For Each ws In ThisWorkbook.Worksheets
        If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
    Next ws
 
    Worksheets(WelcomePage).Activate
End Sub
 
Private Sub ShowAllSheets()
     'Show all worksheets except the macro welcome page
 
    Dim ws As Worksheet
 
    For Each ws In ThisWorkbook.Worksheets
        If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
    Next ws
 
    Worksheets(WelcomePage).Visible = xlSheetVeryHidden
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
    RunWhen = Now + TimeSerial(0, NUM_MINUTES, 0)
    Application.OnTime RunWhen, "SaveAndClose", , True
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
    RunWhen = Now + TimeSerial(0, NUM_MINUTES, 0)
    Application.OnTime RunWhen, "SaveAndClose", , True
End Sub

Should this line be TRUE?
Code: 
[COLOR=magenta]   .Close savechanges:=False[/COLOR]
 
Upvote 0
Changing that line to True didn't work.

Anybody have any ideas? Help?!?
 
Upvote 0
Can anybody help me, please? I've tried everything I can think of & haven't hit on a solution yet.

******************
This works! ... with one exception... I don't want it to ask to save changes, I just want the macro to save the changes & close the file.

Code: 
Option Explicit
 
Const WelcomePage = "Macros"
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
     'Turn off events to prevent unwanted loops
    Application.EnableEvents = False
 
'Evaluate if workbook is saved and emulate default prompts
With ThisWorkbook
   If Not .Saved Then
       Select Case MsgBox("Do you want to save the changes you made to '" & .Name & "'?", _
           vbYesNoCancel + vbExclamation)
       Case Is = vbYes
            'Call customized save routine
           Call CustomSave
       Case Is = vbNo
            'Do not save
       Case Is = vbCancel
            'Set up procedure to cancel close
           Cancel = True
       End Select
    End If
 
         'If Cancel was clicked, turn events back on and cancel close,
         'otherwise close the workbook without saving further changes
        If Not Cancel = True Then
            .Saved = True
            Application.EnableEvents = True
        .Close savechanges:=False
        Else
            Application.EnableEvents = True
        End If
    End With
    On Error Resume Next
    Application.OnTime RunWhen, "SaveAndClose", , False
    On Error GoTo 0
End Sub
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
     'Turn off events to prevent unwanted loops
    Application.EnableEvents = False
 
     'Call customized save routine and set workbook's saved property to true
     '(To cancel regular saving)
    Call CustomSave(SaveAsUI)
    Cancel = True
 
     'Turn events back on an set saved property to true
    Application.EnableEvents = True
    ThisWorkbook.Saved = True
End Sub
 
Private Sub Workbook_Open()
     'Unhide all worksheets
    Application.ScreenUpdating = False
    Call ShowAllSheets
    Application.ScreenUpdating = True
     'Start timer
    On Error Resume Next
    Application.OnTime RunWhen, "SaveAndClose", , False
    On Error GoTo 0
    RunWhen = Now + TimeSerial(0, NUM_MINUTES, 0)
    Application.OnTime RunWhen, "SaveAndClose", , True
End Sub
Private Sub CustomSave(Optional SaveAs As Boolean)
    Dim ws As Worksheet, aWs As Worksheet, newFname As String
     'Turn off screen flashing
    Application.ScreenUpdating = False
 
     'Record active worksheet
    Set aWs = ActiveSheet
 
     'Hide all sheets
    Call HideAllSheets
 
     'Save workbook directly or prompt for saveas filename
    If SaveAs = True Then
        newFname = Application.GetSaveAsFilename( _
        fileFilter:="Excel Files (*.xls), *.xls")
        If Not newFname = "False" Then ThisWorkbook.SaveAs newFname
    Else
        ThisWorkbook.Save
    End If
 
     'Restore file to where user was
    Call ShowAllSheets
    aWs.Activate
 
     'Restore screen updates
    Application.ScreenUpdating = True
End Sub
 
Private Sub HideAllSheets()
     'Hide all worksheets except the macro welcome page
    Dim ws As Worksheet
 
    Worksheets(WelcomePage).Visible = xlSheetVisible
 
    For Each ws In ThisWorkbook.Worksheets
        If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
    Next ws
 
    Worksheets(WelcomePage).Activate
End Sub
 
Private Sub ShowAllSheets()
     'Show all worksheets except the macro welcome page
 
    Dim ws As Worksheet
 
    For Each ws In ThisWorkbook.Worksheets
        If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
    Next ws
 
    Worksheets(WelcomePage).Visible = xlSheetVeryHidden
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
    RunWhen = Now + TimeSerial(0, NUM_MINUTES, 0)
    Application.OnTime RunWhen, "SaveAndClose", , True
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
    RunWhen = Now + TimeSerial(0, NUM_MINUTES, 0)
    Application.OnTime RunWhen, "SaveAndClose", , True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
Unable to Suppress Save Prompt
Replies
4
Views
240
davidam
D
S
  • Question Question
User Form not Loading
Replies
5
Views
150
StevieMP
S
C
  • Solved
My code in BeforeSave is preventing the save???
Replies
5
Views
302
Clif McIrvin
C
L
  • Question Question
VBA to autosave and close after a set amount of time
Replies
3
Views
561
Anthony47
A
A
  • Solved
Workbook_BeforeClose() is not preventing user to close even when specific ranges are blank
Replies
4
Views
243
John_w
J

Forum statistics

Threads
1,223,231
Messages
6,170,885
Members
452,364
Latest member
springate

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top