The Workbook.BeforeClose event triggers when the workbook is about to close but before the saving message prompt which allows cancelling it.
How can I detect when the workbook is already closing past the point where it can be cancelled without removing nor replacing the saving message with a custom one?
One workaround I have found online is to use the event together with the Workbook.Deactivate event which looks like this:
Code in the workbook:
Private Sub Workbook_BeforeClose(ByRef Cancel As Boolean)
closing_event = True
check_time = VBA.Now + VBA.TimeSerial(Hour:=0, Minute:=0, Second:=1)
Excel.Application.OnTime EarliestTime:=check_time, Procedure:="disable_closing_event"
End Sub
Private Sub Workbook_Deactivate()
If closing_event Then
VBA.MsgBox Prompt:="Closing event."
Excel.Application.OnTime EarliestTime:=check_time, Procedure:="disable_closing_event", Schedule:=False
End If
End Sub
Code in a module:
Public closing_event As Boolean
Public check_time As Date
Public Sub disable_closing_event()
closing_event = False
End Sub
One very specific edge case where it triggers incorrectly is if you click to close the workbook and in less than one second close the saving message (press Esc to do it fast enough) and change to another workbook (Alt + Tab) it triggers the Deactivate event with the closing_event condition variable still set to True because disable_closing_event has still not set it to False (scheduled by Application.OnTime for when one second goes by).
I would like to find a solution that isn't so much of a workaround and that works correctly against that edge case.
Edit:
The accepted answer has the best solution in my opinion out of all the current answers. I have modified it for my needs and preference to the following code in the workbook:
Private WorkbookClosing As Boolean
Private Sub Workbook_BeforeClose(Cancel As Boolean)
WorkbookClosing = True
End Sub
Private Sub Workbook_Deactivate()
If WorkbookClosing And ThisWorkbook.Name = ActiveWindow.Caption Then
Workbook_Closing
Else
WorkbookClosing = False
End If
End Sub
Private Sub Workbook_Closing()
MsgBox "Workbook_Closing event."
End Sub
This is an evolution of my 1st Answer - it detects the edge case problem by comparing the ActiveWindow.Caption against ThisWorkbook.Name so it can detect that issue and deal with it. It's not the most elegant solution but I believe it works.
All Code in the Workbook most of it in DeActivate
Public ByeBye As String
Private Sub Workbook_BeforeClose(Cancel As Boolean)
ByeBye = "B4C"
End Sub
Private Sub Workbook_Deactivate()
If ByeBye = "B4C" Then
If ActiveWindow.Caption = ThisWorkbook.Name Then
If ThisWorkbook.Saved Then
MsgBox "No problem - Closing after Saving"
Else
MsgBox "No problem - Closing without Saving"
End If
Else
If ThisWorkbook.Saved Then
MsgBox "No problem - New Workbook Activation"
Else
MsgBox "Oops Try Again You Cannot Activate '" & ActiveWindow.Caption & "' until '" & ThisWorkbook.Name & "' has completed processing & IT HAS NOW COMPLETED", vbOKOnly, "Hiding"
ThisWorkbook.Activate
End If
End If
Else
MsgBox "No problem - Just Hiding"
End If
ByeBye = "Done"
End Sub
Private Sub Workbook_Open()
ByeBye = "OPENED"
End Sub
In response to comment about saving I tested this for 7 possible combinations as follows
1) Closing without Edits - No Saving Involved ... MsgBox Prompted with ... No problem - Closing after Saving
2) Not closing - Just Switch Workbook - Whether Edited or Not ... MsgBox Prompted with ... No problem - Just Hiding
3) Not closing - Switch Workbook - After Edit & Cancel ... MsgBox Prompted with ... Oops Try Again …
4) Closing and saving ... MsgBox Prompted with ... No problem - Closing after Saving
5) Closing and Saving after a prior Cancel ... MsgBox Prompted with ... No problem - Closing after Saving
6) Closing but Not Saving ... MsgBox Prompted with ... No problem - Closing without Saving
7) Closing but not Saving after a prior Cancel ... MsgBox Prompted with ... No problem - Closing without Saving
I think trying to cancel the close event is the wrong approach for what you are trying to do. A better approach would be to have a function that is only called when the workbook is actually closing.
Thank you for the comments regarding OnTime not being called while the dialog is open as that pointed me in the right direction. What we need to test is the time between the workbook deactivation and the closing of either the workbook itself or the save dialog. Using the Excel.Application.OnTime function to set this close time means this is possible as it can be delayed until the save dialogue has closed.
Once we have this time, a simple comparison to the deactivation time allows us to decide whether to call the exit function or not.
I initially ran into issues with the workbook reopening to run the .OnTime procedure, so an artificial delay needs to be added into the Deactivation function so the workbook hasn't closed until the close time has been set. Using the code from here - Delay Macro to allow events to finish we can accomplish this.
In ThisWorkbook
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Excel.Application.OnTime EarliestTime:=Now, Procedure:="SetCloseTime"
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Timer < CloseTime + 0.2 Then Call CloseProcedure
End Sub
Private Sub Workbook_Deactivate()
Delay (0.3)
If Timer < CloseTime + 0.4 Then Call CloseProcedure
End Sub
In a module
Option Explicit
Public CloseTime As Single
Function SetCloseTime()
CloseTime = Timer
End Function
Function Delay(Seconds As Single)
Dim StopTime As Single: StopTime = Timer + Seconds
Do While Timer < StopTime
DoEvents
Loop
End Function
Function CloseProcedure()
MsgBox "Excel is closing"
End Function
The .OnTime seems to run within one second cycles which dictates the length of the delay and the time difference test has a little leeway added with an additional 1/10th of a second (which I found necessary). These timings could potentially need slight tweaking but have so far worked for me with the different scenarios when closing the workbook.
In order to get around your edge case, you need to handle the case where the workbook is deactivated within 1 second of closing it, but only when the save prompt was displayed.
To check if less than 1 second has elapsed, use a high resolution timer to store the time in the Workbook_BeforeClose event, and then compare against it in the Workbook_Deactivate event. Assuming that clsTimer is a suitable high res timer, your code should now be:
Private MyTimer As clsTimer
Private StartTime As Currency
Private Sub Workbook_BeforeClose(ByRef Cancel As Boolean)
closing_event = True
Set MyTimer = New clsTimer
StartTime = MyTimer.MicroTimer
check_time = VBA.Now + VBA.TimeSerial(Hour:=0, Minute:=0, Second:=1)
Excel.Application.OnTime EarliestTime:=check_time, Procedure:="disable_closing_event"
End Sub
Private Sub Workbook_Deactivate()
If closing_event Then
If Not ThisWorkbook.Saved Then
'The Save prompt must have been displayed, and the user clicked No or Cancel or pressed Escape
If MyTimer.MicroTimer - StartTime < 1 Then
'The user must have pressed Escape and Alt-Tabbed
closing_event = False
Else
'Your Windows API calls here
End If
Else
'The workbook was saved before the close event, so the Save prompt was not displayed
'Your Windows API calls here
End If
Excel.Application.OnTime EarliestTime:=check_time, Procedure:="disable_closing_event", Schedule:=False
End If
Set MyTimer = Nothing
End Sub
The class module for clsTimer looks like this:
Private Declare PtrSafe Function getFrequency Lib "kernel32" _
Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare PtrSafe Function getTickCount Lib "kernel32" _
Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long
Public Function MicroTimer() As Currency
' Returns seconds.
Dim cyTicks1 As Currency
Static cyFrequency As Currency
MicroTimer = 0
' Get frequency.
If cyFrequency = 0 Then getFrequency cyFrequency
' Get ticks.
getTickCount cyTicks1
' Seconds
If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency
End Function
This post could be helpful https://www.dummies.com/software/microsoft-office/excel/an-excel-macro-to-save-a-workbook-before-closing/
I found code below from the book Excel 2016 Power Programming with VBA, by Michael Alexander
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim msg As String, ans as integer
If Me.Saved = False Then
msg = "Do you want to save?"
ans = MsgBox(msg, vbquestion+vbyesnocancel)
Select Case ans
Case vbYes: Me.Save
Case vbCancel: Cancel = True
End Select
End If
Call mySub
Me.Saved = True
End Sub
I think deactivate is the best way to capture this.
Beforeclose might occur earlier than Save event if the document was not saved. So Excel might prompt to save before closure.
But Deactivate is the final event before closure (after save). So this can be used.
had a similar problem and tried to run some macro before closing but it is dependad whether user wants to save workbook or not.
My solution was the code below, though there is a problem, that window of excel always stays open.
Public ClosedByProgram As Boolean
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not ClosedByProgram Then
Cancel = True
Dim Ans As String
Ans = MsgBox("Want to save your changes to '" & ThisWorkbook.Name & "'?", vbYesNoCancel, "Microsoft Excel")
If Ans = vbNo Then
ClosedByProgram = True
ThisWorkbook.Close
ElseIf Ans = vbYes Then
Dim STR As String: STR = "'" & ThisWorkbook.Name & "'!" & "mod16_Versioning.IsSuitableForSaving"
Dim isForSaving As Boolean: isForSaving = Application.Run(STR, SaveAsUI)
If isForSaving Then
Dim STRToRun As String
STRToRun = "'" & ThisWorkbook.Name & "'!" & "mod02_Events.BeforeSave"
Application.Run STRToRun, SaveAsUI
Dim STRVersions As String: STRVersions = "'" & ThisWorkbook.Name & "'!" & "mod16_Versioning.MakeVersion"
Dim blankCheck As Boolean: blankCheck = Application.Run(STRVersions, SaveAsUI)
ClosedByProgram = True
ThisWorkbook.Close
End If
End If
Else
ThisWorkbook.Saved = True
Application.Quit
End If
End Sub
This seems to work
Code in the WorkBook
Public ByeBye As String
Private Sub Workbook_BeforeClose(Cancel As Boolean)
ByeBye = "BB # " & Now()
End Sub
Private Sub Workbook_Deactivate()
If Left(ByeBye, 2) = "BB" Then
ByeBye="Done"
MsgBox "Closing"
Else
ByeBye="Done"
MsgBox "DeActivating BUT NOT Closing"
End If
End Sub
Private Sub Workbook_Open()
ByeBye = "OP # " & Now()
End Sub
Just uses a public variable ByeBye
You must initialise it in WorkBook.Open
You must Set it in WorkBook.BeforeClose
and can test it in WorkBook.DeActivate
In case it is needed for this to work even after a VBA crash - and loss of ByeBye value I'm resetting it in the Workbook_SheetChange and in WorkBook_SheetSelectionChange
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
ByeBye = "SC # " & Now()
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
ByeBye = "SSC # " & Now()
End Sub
The above addendum is really only needed if you were going to use the string default of "" for the tested value - but I'm using "BB # " & Now() so this is not really needed
Related
Hello One of the VP where I work made a workbook that has the below macro in it. For some reason after I open the file and close it on my own the file re-opens itself every so often. Is this because the timer in the workbook is set to reset its closing process? I am not very well versed in VBA yet so that may not be even close to what the Sub Reset is doing. Note this apparently only happens to me and not anyone else and we have no idea why. only VBA experience I have is like making workbooks that don't close as pranks or making time stamps or color counting formulas.
Dim xTime As String
Dim xWB As Workbook
Private Sub Workbook_Open()
'Updated by Extendoffice 2019/1/20
On Error Resume Next
xTime = "00:30:00"
Set xWB = ActiveWorkbook
If xTime = "" Then Exit Sub
Reset
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
On Error Resume Next
If xTime = "00:30:00" Then Exit Sub
Reset
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
If xTime = "" Then Exit Sub
Reset
End Sub
Sub Reset()
Static xCloseTime
If xCloseTime <> 0 Then
ActiveWorkbook.Application.OnTime xCloseTime, "SaveWork1", , False
End If
xCloseTime = Now + TimeValue(xTime)
ActiveWorkbook.Application.OnTime xCloseTime, "SaveWork1", , True
End Sub
The timer is a async process so it will keep running in background
you can reset it on closing of the workbook.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Reset
End Sub
The workbook is being reopened when Application.OnTime calls the SaveWork1 that is attached to it. Static xCloseTime is storing the time that the SaveWork1 is scheduled to be ran. The time is being stored so that the Application.OnTime event can be cancelled.
I believe that you are the only one being affected because you are the only one that dabbles in VBA. VBA errors may cause Static variables to lose their values. When Static xCloseTime the SaveWork1 is rescheduled.
Sorry about the confusing title. But if a file is opened by someone else, when I open it I get the message that it's opened by someone else and I get the option to open it without being able to save it.
If I choose that option when I close the file it auto opens again.
The file has a few macros that is most likely the cause but I can't understand how it causes this issue.
First of all. The file has an inactivity tracker in a module that runs every five seconds:
Private Type LASTINPUTINFO
cbSize As Long
dwTime As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
Private Declare PtrSafe Sub GetLastInputInfo Lib "User32" (ByRef plii As LASTINPUTINFO)
#Else
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub GetLastInputInfo Lib "User32" (ByRef plii As LASTINPUTINFO)
#End If
Public tid As Variant
Public lista As Scripting.Dictionary
Function IdleTime() As Single
Dim a As LASTINPUTINFO
a.cbSize = LenB(a)
GetLastInputInfo a
IdleTime = (GetTickCount - a.dwTime) / 1000
End Function
Sub Form_Timer()
' lookup the inaktivity time for current user if 0
If tid = 0 Then
LR = ThisWorkbook.Sheets("Inaktivitet").Cells(ThisWorkbook.Sheets("Inaktivitet").Rows.Count, "B").End(xlUp).Row
tid = Application.VLookup(UCase(Environ("UserName")), ThisWorkbook.Sheets("Inaktivitet").Range("B17:G" & LR), 6, False)
If Not IsError(tid) Then
tid = tid * 60
Else
' if user does not have a specified inactivity time set the "other" time to user
tid = Application.VLookup("Övriga", ThisWorkbook.Sheets("Inaktivitet").Range("B17:G" & LR), 6, False)
tid = tid * 60
End If
End If
tme = IdleTime
'Debug.Print tme & " " & Now()
' display warning when less than 65 seconds
If tid - tme < 65 Then
UserForm2.Show vbModeless
DoEvents
End If
If tme >= tid Then
If lista.Exists(UCase(Environ("UserName"))) Then ThisWorkbook.Save
Application.DisplayAlerts = False
ThisWorkbook.Close
End If
On Error Resume Next
Application.OnTime RunTime, "Form_Timer", Schedule:=False
Application.OnTime Now + TimeSerial(0, 0, 5), "Form_Timer"
End Sub
This code is initiated with the workbook_open event below.
The dictionary created is to save the inactivity times (and write permissions) in a dictionary so that it "can't" be manipulated without save permission.
Public RunTime
Private Sub Workbook_Open()
Set lista = New Scripting.Dictionary
For I = 18 To ThisWorkbook.Sheets("Inaktivitet").Range("B200").End(xlUp).Row
If ThisWorkbook.Sheets("Inaktivitet").Range("B" & I).Value <> "" And ThisWorkbook.Sheets("Inaktivitet").Range("B" & I).Value <> "Övriga" Then
lista.Add Key:=ThisWorkbook.Sheets("Inaktivitet").Range("B" & I).Value, Item:=ThisWorkbook.Sheets("Inaktivitet").Range("C" & I).Value
End If
Next I
Application.Calculation = xlCalculationManual ' This is done to make the workbook more responsive due to other event macros
Form_Timer ' <---- Here
End Sub
And in BeforeSave I make sure the username is in the dictionary, if not they are not allowed to save, and in BeforeClose I turn off the inactivity tracker and set calculation to automatic:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnTime RunTime, "Form_Timer", Schedule:=False
Application.Calculation = xlAutomatic
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
On Error GoTo err
If Not lista.Exists(UCase(Environ("UserName"))) Then
Cancel = True
MsgBox "Du har inte behörighet att spara schemat" ' you don't have permissions to save.
End If
GoTo subend:
err:
MsgBox "Något har gått fel, det går inte spara." & vbNewLine & "filen går in i felsäkert läge nu. Kopiera celler/blad som är ändrade till en ny excelfil och spara den." & vbNewLine & "Stäng därefter alla Excelfiler innan du försöker öppna någon Excelfil igen."
Application.EnableEvents = False
subend:
On Error GoTo 0
End Sub
When the user change active workbook the calculation toggles:
But I doubt this is the cause of it.
Private Sub Workbook_WindowActivate(ByVal Wn As Window)
If Wn.Caption = ThisWorkbook.Name Then
Application.Calculation = xlCalculationManual
Else
Application.Calculation = xlCalculationAutomatic
End If
End Sub
Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
Application.Calculation = xlCalculationAutomatic
End Sub
The rest of the macro running is SheetChange, SheetActivate, and SheetSelectionChange code to color text on the sheets to help the user and display various messages.
What I believe is the issue is that the inactivity timer, that it by some reason runs again after the workbook has been closed and thus open the workbook to do it.
Or do you see something else that cause the workbook to auto open again? It only happens when someone else has the write permissions and I open it no write permissions.
When I close the workbook I get the question if I want to save the changes and I press No.
This should turn off the inactivity timer and then close it, and stop. At least as I see it.
I know that the inactivity timer can be turned off by a skilled person and that the write permission using the dictionary is not 100% safe, but it's not intended to be.
The issue is that RunTime variable is not updated in the inactivity timer.
I missed that part.
The current inactivity (sub Form_timer()) code ends with:
If tme >= tid Then
If lista.Exists(UCase(Environ("UserName"))) Then ThisWorkbook.Save
Application.DisplayAlerts = False
ThisWorkbook.Close
End If
On Error Resume Next
Application.OnTime RunTime, "Form_Timer", Schedule:=False
Application.OnTime Now + TimeSerial(0, 0, 5), "Form_Timer"
End Sub
It should have been:
If tme >= tid Then
If lista.Exists(UCase(Environ("UserName"))) Then ThisWorkbook.Save
Application.DisplayAlerts = False
ThisWorkbook.Close
End If
On Error Resume Next
Application.OnTime RunTime, "Form_Timer", Schedule:=False
RunTime = Now + TimeSerial(0, 0, 5)
Application.OnTime RunTime, "Form_Timer"
End Sub
This now makes sure I have RunTime set correctly so that it can be canceled with the BeforeSave event.
Something which we encounter on a daily basis at work is when a member of the team opens Excel Workbook from a network share to update the workbook and forget to save and close the file after he is finished.
The issue arise when the user locks his workstation and walks away from his desk leaving his co-workers unable to modify the shared excel workbook (read only).
P.S Locking your workstation before each time you leave your desk is something crucial for security reasons and I encourage the reader to adopt this good cyber hygiene habit.
How can I solve this issue once and for all?
One might argue that opening such documents in the cloud might solve the problem but this depends on the nature of the contents being stored in the document.
I had some initial parameters defined wrong and it's always better to do stuff like this at the Modules level.
For your ThisWorkbook section, only have this code:
Private Sub Workbook_Open()
Call TheTimerMac
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Call RestApplicationTimer
End Sub
Then in a standard Module insert the below code. The settings can be adjusted with the constants, which it looks like you understand (btw thanks for CDATE function -- shorter than TimeValeu)
I also inserted a couple audio warnings, partially just for my own entertainment. You look sharp enough that you can just nuke them if you don't like them.
'STANDARD MODULE CODE
'Constants
'Time settings
Const idleTimeLIMIT As String = "00:35:00" '<---- Edit this to whatever timer you want (hour:min:sec)
Const checkIntervalTime As String = "00:01:00" '<---- this can be executed frequently as it has low overhead
'Set this variable TRUE to confirm the macro is working with popup messages
Const conFirmRunning As Boolean = False
Dim LastCalculate As Date 'Make sure this is outside and above the other macros
Option Private Module
Public Sub TheTimerMac()
'message you can have displayed to make sure it's running
If conFirmRunning Then MsgBox "TheTimerMac is running."
'Schedules application to execute below macro at set time.
Application.OnTime Now + CDate(checkIntervalTime), "AnyBodyWorking"
End Sub
Private Sub AnyBodyWorking()
'OPTIONAL Warning messages to be spoken
Const TenMinuteWarning As String = "Your file will save and close in approximately 10 minutes"
Const FiveMinuteWarning As String = "Your file will save and close in approximately 5 minutes"
Const OneMinuteWarning As String = "This is the last warning. Your file will save and close in a little over a minute."
'message you can have displayed to make sure it's running
If conFirmRunning Then MsgBox "AnyBodyWorking Macro is running."
If LastCalculate = 0 Then
'Won't close application if lastCalc hasn't been set
Call RestApplicationTimer
ElseIf Now > LastCalculate Then
'if nothing has happened in the last idleTime interval... then it closes.
'close and lock it up!!
ThisWorkbook.Save
ThisWorkbook.Close
Exit Sub 'not even sure if this is needed, but probably good to be sure
''Optional spoken warnings
ElseIf DateDiff("S", Now, LastCalculate) < 60 Then
Application.Speech.Speak OneMinuteWarning
ElseIf DateDiff("S", Now, LastCalculate) < 300 Then
Application.Speech.Speak FiveMinuteWarning
ElseIf DateDiff("S", Now, LastCalculate) < 600 Then
Application.Speech.Speak TenMinuteWarnin
End If
Call TheTimerMac
End Sub
Sub RestApplicationTimer()
LastCalculate = Now + CDate(idleTimeLIMIT)
End Sub
Lastly, I think you could slightly improve the the locked function to be as follows and you could inculde it in your if statements.
Function IsLocked() As Boolean
IsLocked = _
GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
Environ$("computername") & "\root\cimv2"). _
ExecQuery("select * from Win32_Process where Name='logonui.exe'").Count > 0
End Function
Save the excel file as .xlsm to enable the storing of macros in the workbook itself.
Go to: Developer Tab -> Visual Basic
Double click: 'This Workbook', on the left hand pane
Paste the following VBA code:
Private Sub Workbook_Open()
Application.OnTime Now + TimeValue("00:01:00"), "Save1"
End Sub
Right Click VBAProject -> Insert -> Module
Paste the following VBA Code:
Sub Save1()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
If IsLocked(Environ$("computername")) > 0 Then
Workbooks("book1test.xlsm").Close SaveChanges:=True
End If
Application.OnTime Now + TimeValue("00:01:00"), "Save1"
End Sub
Function IsLocked(strComputer)
With GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
IsLocked = .ExecQuery("select * from Win32_Process where Name='logonui.exe'").Count '
End With
End Function
Save the Macro: Ctrl+s
This macro will be triggered every time you open the workbook, save your work every minute and only close the workbook if your screen/workstation is logged. You can remove the auto-save feature if you want.
Credits:
Check if computer is locked using VBscript
How to save Excel file every say minute?
#PGSystemTester this was the only way I could get it to work:
In ThisWorkbook:
Public idleTIME As Date '<---- Edit this to whatever timer you want (hour:min:sec)
Private Sub Workbook_Open()
idleTIME = CDate("00:10:00")
LastCalculate = Now + idleTIME
Check
End Sub
Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
LastCalculate = Now + idleTIME
End Sub
In module Option 1:
Public LastCalculate As Date
Const checkIntervalTime As String = "00:01:00"
Sub Check()
Call TheTimerMac
End Sub
Private Sub TheTimerMac()
Dim nextRunTime As Date
nextRunTime = Now + CDate(checkIntervalTime)
'Schedules application to execute below macro at set time.
Application.OnTime nextRunTime, "AnyBodyWorking"
End Sub
Private Sub AnyBodyWorking()
If Now > LastCalculate Then
'if nothing has happened in the last idleTime interval... then it closes.
'close and lock it up!!
ThisWorkbook.Save
ThisWorkbook.Close
Else
'executes the timerMacagain
Call TheTimerMac
End If
End Sub
module Option 2 (for locked screen):
Public LastCalculate As Date 'Make sure this is outside and above the other macros
Const checkIntervalTime As String = "00:00:30" '<---- this can be frequent as it has low overhead
Sub Check()
Call TheTimerMac
End Sub
Private Sub TheTimerMac()
Dim nextRunTime As Date
nextRunTime = Now + CDate(checkIntervalTime)
'Schedules application to execute below macro at set time.
Application.OnTime nextRunTime, "AnyBodyWorking"
End Sub
Private Sub AnyBodyWorking()
If Now > LastCalculate Or (IsLocked("FIBRE-X") > 0) Then
'if nothing has happened in the last interval idleTime OR Screen is Locked... then it closes.
'close and lock it up!!
ThisWorkbook.Save
ThisWorkbook.Close
Else
'executes the timerMacagain
Call TheTimerMac
End If
End Sub
Function IsLocked(strComputer)
With GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
IsLocked = .ExecQuery("select * from Win32_Process where Name='logonui.exe'").Count '
End With
End Function
Anything I can improve on this please?
I want to fire the BeforeDoubleClick-event BEFORE the SelectionChange-event for an EXCEL work-sheet.
The order is normally the other way round: SelectionChange-event first, and later BeforeDoubleClick-event.
My goal is to either run MyDoubleClickCode, if there a double-click, or if NOT, run MyChangeSelectionCode.
The problem relies in the order of event-triggering!
My best solution comes here:
' This Event is **MAYBE** fired secondly and runs the MyDoubleClickCode
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
dblFlag = true
...
MyDoubleClickCode
...
End Sub
' This event is always fired AND runs first
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
dblFlag = false
alertTime = Now + TimeValue("00:00:01")
Application.OnTime alertTime, "MyChangeSelectionSub"
End Sub
' Userdefined subroutine which will run one second after an event ( doubleclick or not).
public sub MyChangeSelectionSub()
If NOT dblFlag then
...
MyChangeSelectionCode
...
End if
End Sub
I use OnTime in my SelectionChange-event to call the MyChangeSelectionSub one second after a selection-change is triggered. This gives times to handle an BeforeDoubleClick-event and do the MyDoubleClickCode - if the cell was also double-clicked. My wanted logic is reached , BUT...
... it is of course very clumpsy and not satisfying: I have to wait one second before the MyChangeSelectionSub starts, instead of just after the BeforeDoubleClick-event has been dealed with.
Maybee there is a kind of logic to make this happend? Any idea?
EDIT: I've edited the code-exampel to be more clear about my problem! And I know now that I can't change the order of events, but how to not use the onTime solution??
This "works" for me, but it doesn't seem stable. Probably the timing of the OnTime method causes an "uncomfortable pause" in execution that we might need to accept. (or improve upon.)
'worksheet (Name) is "Sheet17" in the VBA Properties window
'worksheet Name is "Sheet1" as shown in the worksheet tab in the application Excel
Private double_click_detected As Boolean
Private SelectionChange_target As Range
' This Event is **MAYBE** fired secondly and runs the MyDoubleClickCode
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
double_click_detected = True
'...
MsgBox "MyDoubleClickCode"
'...
End Sub
' This event is always fired AND runs first
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set SelectionChange_target = Target
alertTime = Now + TimeValue("00:00:01")
Application.OnTime alertTime, "Sheet17.MyChangeSelectionSub"
End Sub
' Userdefined subroutine which will run one second after an event ( doubleclick or not).
Public Sub MyChangeSelectionSub()
If Not double_click_detected Then
'...
MsgBox "MyChangeSelectionCode"
'...
End If
End Sub
I found a solution for a similar issue, to avoid Worksheet_SelectionChange before the event Worksheet_BeforeRightClick on https://www.herber.de/forum/archiv/1548to1552/1550413_Worksheet_BeforeRightClick.html (in german) and used it for my test sub.
The whole list of virtual key codes you find on https://learn.microsoft.com/en-us/windows/win32/inputdev/virtual-key-codes
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)'just for sleep
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Const VK_LBUTTON = &H1 'Left mouse button
Const VK_RBUTTON = &H2 'Right mouse button
Const VK_SHIFT = &H10'Shiftkey just for fun to exit the sub
Sub TestGetAsyncKeyState()
Dim RMouseClick As Long, LMouseClick As Long
Dim RMouseClickpr As Long, LMouseClickpr As Long
Dim lShift As Long, iC As Integer
iC = 0
Do
DoEvents
lShift = GetAsyncKeyState(VK_SHIFT)
RMouseClickpr = RMouseClick
LMouseClickpr = LMouseClick
RMouseClick = GetAsyncKeyState(VK_RBUTTON)
LMouseClick = GetAsyncKeyState(VK_LBUTTON)
If RMouseClick <> RMouseClickpr Or LMouseClick <> LMouseClickpr Then Debug.Print vbLf; CStr(iC); ":"
If RMouseClick <> RMouseClickpr Then Debug.Print "Right: "; RMouseClick; "Previous: "; RMouseClickpr
If LMouseClick <> LMouseClickpr Then Debug.Print "Left : "; LMouseClick; "Previous: "; LMouseClickpr
' If RMouseClick <> RMouseClickpr Or LMouseClick <> LMouseClickpr Then Stop
Sleep (1000)
iC = iC + 1
If iC > 120 Then Stop '2
Loop While GetAsyncKeyState(VK_SHIFT) = 0 'End Loop by pressing any of the Shift-Keys
End Sub
It works for mouseclick (1), shortly held mousebutton (-32767) and longer held mousebutton (-32768). Unfortunately not for doubleclick.
Attention: https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getasynckeystate says that it detects the physical mousebuttons. If someone changed the setting it will not detect the correct button. MS says you can correct that with GetSystemMetrics(SM_SWAPBUTTON).
Hope it helps.
I want to close my workbook if it's inactive for 1 minute. But before closing, I want to save a backup of it, but make no changes to the original. How can I incorporate this code:
ActiveWorkbook.SaveAs filename:=filename, FileFormat:=xlWorkbookNormal
into this procedure
Sub SetTimer()
Dim bookname
Dim filename
DownTime = Now + TimeValue("00:01:00")
bookname = ActiveWorkbook.Name
filename = "C:\myhome\backups\" & bookname
Application.OnTime EarliestTime:=DownTime, _
Procedure:="ShutDown", Schedule:=True
End Sub
If I insert it into the code, it asks me to save before the timer is done. I want it to ask after the time is done.
I think this is what you are after:
Public Sub SetTimer()
Dim DownTime As Date
DownTime = Now + TimeValue("00:01:00")
Application.OnTime EarliestTime:=DownTime, _
Procedure:="ShutDown", Schedule:=True
End Sub
Private Sub ShutDown()
' Be careful about using ActiveWorkbook vs ThisWorkbook vs getting a direct reference to the required workbook.
Dim bookname As String
bookname = ActiveWorkbook.Name
Dim filename As String
filename = "C:\myhome\backups\" & bookname
ActiveWorkbook.SaveAs filename:=filename, FileFormat:=xlWorkbookNormal
End Sub
You need to put the SaveAs into a separate method called "ShutDown". I assume that you put it at the end of the original method. The call to Application.OnTime() runs and schedules ShutDown() to be called later on then immediately continues to run the rest of the code in SetTimer().
Just put an event handler in for Workbook_BeforeClose. I'd personally check to see if it had been altered too so you don't get a bunch of needless backups:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
If Not Me.Saved Then
Me.SaveAs "C:\myhome\backups\" & Me.Name, xlWorkbookNormal
End If
Application.DisplayAlerts = True
End Sub