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

zakasnak

Active Member
Joined
Sep 21, 2005
Messages
307
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)
 

zakasnak

Active Member
Joined
Sep 21, 2005
Messages
307
I assume that I can only have one Workbook_Open & one Workbook_Close event in the ThisWorkbook module.
 

zakasnak

Active Member
Joined
Sep 21, 2005
Messages
307
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]
 

zakasnak

Active Member
Joined
Sep 21, 2005
Messages
307
Changing that line to True didn't work.

Anybody have any ideas? Help?!?
 

zakasnak

Active Member
Joined
Sep 21, 2005
Messages
307
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
 

Forum statistics

Threads
1,085,341
Messages
5,383,057
Members
401,813
Latest member
Lucy_Wood

Some videos you may like

This Week's Hot Topics

Top