gravanoc
Active Member
- Joined
- Oct 20, 2015
- Messages
- 348
- Office Version
- 365
- Platform
- Windows
- Mobile
I found this thread: Mr Excel
Unfortunately it is a 32-bit solution. I looked at my WinAPI.txt and converted most of the declarations to 64-bit, but there didn't appear to be anything matching GetLastInputInfo in there. There was also a GetTickCount64 that I figured I should use rather than the GetTickCount a couple of lines down. When running it the code stumbles at a couple spots like:
I changed the above to AppHwnd = Application.Hwnd
I'm not positive that is right. It does continue to run until:
It gives me a Type Mismatch error at CheckTimeOutStatus. Any ideas how to modify this to proceed? Here is the full code. The first part is in the ThisWorkbook module, the rest is in a standard module. Some of it has been converted to 64-bit where it made sense to do so.
ThisWorkbook module
Standard Module
Unfortunately it is a 32-bit solution. I looked at my WinAPI.txt and converted most of the declarations to 64-bit, but there didn't appear to be anything matching GetLastInputInfo in there. There was also a GetTickCount64 that I figured I should use rather than the GetTickCount a couple of lines down. When running it the code stumbles at a couple spots like:
VBA Code:
AppHwnd = FindWindow("XLMAIN", Application.Caption)I changed the above to AppHwnd = Application.Hwnd
I'm not positive that is right. It does continue to run until:
VBA Code:
Function ResetTimer()
TimerId = SetTimer(0, TimerId, TimerCheckIntervalMilliseconds, AddressOf CheckTimeOutStatus)
End FunctionIt gives me a Type Mismatch error at CheckTimeOutStatus. Any ideas how to modify this to proceed? Here is the full code. The first part is in the ThisWorkbook module, the rest is in a standard module. Some of it has been converted to 64-bit where it made sense to do so.
ThisWorkbook module
VBA Code:
Option Explicit
Private Sub Workbook_Open()
MsgBox "This workbook will automatically save and close if there are 5 consecutive seconds of inactivity. If this is the only workbook open, Excel will quit as well."
RunOnTimePlus
End Sub
Sub RunOnTimePlus()
Dim OnTimeArgs As OnTimeArguments
On Error GoTo Err_Example
With OnTimeArgs
.TimeOutOn = OnUserIdle
.ProcedureName = "ThisWorkbook.TimedOut"
.CheckIntervalSeconds = 1
.Seconds = 5
End With
StartOnTimePlus OnTimeArgs
Exit Sub
Err_Example:
MsgBox "Error Number: " & Err.Number & vbCrLf & vbCrLf & Err.Description, , Err.Source
End Sub
Friend Sub TimedOut()
If Ok2CloseApp Then
Me.Save
Application.Quit
Else
Me.Close True
End If
End Sub
Private Function Ok2CloseApp() As Boolean
Dim wb As Workbook, WBCnt As Integer
For Each wb In Application.Workbooks
If wb.Path <> Application.StartupPath Or Not wb.IsAddin Then
WBCnt = WBCnt + 1
End If
Next
Ok2CloseApp = (WBCnt = 1)
End FunctionStandard Module
VBA Code:
'StopOnTimePlus comment it out
' to initiate a timeout from another application, use the SetProp API function along with the Desktop's hWnd
' Example
' Sub Example()
' SetProp GetDesktopWindow, "OnTimePlus.xls", CLng(True)
' End Sub
' will fire the timeout in this workbook
' the timeout may not occur immediately the delay depends on the value you
' assign to OnTimeArguments.CheckIntervalSeconds
'
' order of precedence:
' 1. OnTimeOutFromExternal
' 2. OnTime
' 3. OnWorkBookDeactivation (and/or) OnApplicationDeactivation (and/or) OnUserIdle
'
' the min timeout is 1 second
'
' if argument AtDateTime is assigned a value then OnTimeFlag = True
'
' if OnTimeFlag = True then argument AtDateTime must contain a valid date
'
' OnTimeArguments.CheckIntervalSeconds is the interval the code checks for time out conditions
'
' Each call to OnTimePlus supercedes previous calls
'
' You can call OnTimePlus from your timeout procedure to restart it automatically
'
' OnUserIdle is an application wide notification, not system wide, and
' relates to keyboard and mouse activity only
'
' the Function TimedOut() is the default function. I recommend that you assign a valid
' procedure name to the OnTimeArguments.ProcedureName arg. This procedure should be
' located elsewhere in your project. If it is locted in a public object module such
' as a workbook or worksheet class, make sure you qualify it as a member using the codename
' "ThisWorkbook.MyProcedure" or "Sheet1.MyProcedure"
'
' TimeOutOn may be any combination of TimeOutType enum values.
' Explanations
'
' TimeOutOn = OnTime + OnApplicationDeactivation + OnUserIdle
' will time out if...
' 1. the application loses focus or is minimized for the amount of time defined in Hours, Minutes, or Seconds or
' 2. no user activity is detected for the amount of time defined in Hours, Minutes, or Seconds or
' 3. the AtDateTime has been equaled by the system time
'
' TimeOutOn = OnTime
' will time out if...
' 1. the AtDateTime has been equaled by the system time and is the same as Application.OnTime
'
' TimeOutOn = OnTimeOutFromExternal
' will time out if...
' 1. simply allows the workbook to be timed out from an another
' procedure located within the host application or an external application
' OnTimeArguments.CheckIntervalSeconds should be set to a lower value
'
' TimeOutOn = OnTime
' will time out if...
' 1. the AtDateTime has been equaled by the system time
'
' TimeOutOn = OnApplicationDeactivation + OnWorkBookDeactivation + OnUserIdle + OnTimeOutFromExternal
' will time out if...
' 1. the application loses focus or is minimized for the amount of time defined in Hours, Minutes, or Seconds or
' 2. no user activity is detected for the amount of time defined in Hours, Minutes, or Seconds or
' 3. the workbook is deactivated for the amount of time defined in Hours, Minutes, or Seconds or
' 4. a timeout command is sent from another source
Public Enum TimeOutType
OnTimeOutFromExternal = 1
OnTime = 2
OnWorkBookDeactivation = 4
OnApplicationDeactivation = 8
OnUserIdle = 16
End Enum
Public Type OnTimeArguments
TimeOutOn As TimeOutType
AtDateTime As Date
Hours As Double
Minutes As Double
Seconds As Double
CheckIntervalSeconds As Long
ProcedureName As String
End Type
Private Type LASTINPUTINFO
cbSize As Long
dwTime As Long
End Type
Private Declare PtrSafe Function GetTickCount64 Lib "kernel32" () As LongLong
Private Declare PtrSafe Function GetLastInputInfo Lib "user32.dll" (ByRef plii As LASTINPUTINFO) As Long
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Const MAXIMUM_INTERVAL_SECONDS As Long = 86400
Private Const MINIMUM_INTERVAL_SECONDS As Long = 1
Private TimerId As Long
Private TimerCheckIntervalMilliseconds As Long
Private TimeOutOnTime(1) As Date
Private TotalSeconds As Double
Private RunProcedureName As String
Private OnTimeOutFromExternalFlag As Boolean
Private OnTimeFlag As Boolean
Private OnWorkBookDeactivationFlag As Boolean
Private OnApplicationDeactivationFlag As Boolean
Private OnUserIdleFlag As Boolean
Private LastInputTickCount As Long
Private AppHwnd As Long
Private OnTimeOutFromExternalPropName As String
Sub Examples()
Dim OnTimeArgs As OnTimeArguments
On Error GoTo Err_Example
' Will shut down the workbook if no activity is detected in 2 hours and 30 minutes
' or at midnight tommorrow. Whichever comes first. Will check for these conditions
' every thirty seconds. The procedure named "TimedOut" located in ThisWorkbook will fire
With OnTimeArgs
.TimeOutOn = OnUserIdle + OnTime
' .AtDateTime = Date + 1
.ProcedureName = "ThisWorkbook.TimedOut"
.CheckIntervalSeconds = 30
.Hours = 2
.Minutes = 30
End With
'The procedure named "TimedOut" located in ThisWorkbook will fire if
'there are 10 seconds of inactivity
'the workbook will automatically save and close
With OnTimeArgs
.TimeOutOn = OnUserIdle
.ProcedureName = "ThisWorkbook.TimedOut"
.CheckIntervalSeconds = 1
.Seconds = 10
End With
StartOnTimePlus OnTimeArgs
Exit Sub
Err_Example:
MsgBox "Error Number: " & Err.Number & vbCrLf & vbCrLf & Err.Description, , Err.Source
End Sub
Public Function StopOnTimePlus() As Boolean
StopOnTimePlus = Not (KillTimer(0, TimerId) = 0)
End Function
Public Function StartOnTimePlus(Args As OnTimeArguments) As Boolean
Dim MinimumInterval As Long
On Error GoTo Err_OnTimePlus
If Args.TimeOutOn = 0 Then
Err.Raise 10004, "Sub OnTimePlus", "Argument ""OnTimeArguments.TimeOutOn"" type must contain one or more assignments."
Exit Function
End If
ResetVariables
If TimerId <> 0 Then
StopOnTimePlus
TimerId = 0
End If
If Args.CheckIntervalSeconds < MINIMUM_INTERVAL_SECONDS Then Args.CheckIntervalSeconds = MINIMUM_INTERVAL_SECONDS
If Args.CheckIntervalSeconds > MAXIMUM_INTERVAL_SECONDS Then Args.CheckIntervalSeconds = MAXIMUM_INTERVAL_SECONDS
OnTimeOutFromExternalFlag = Args.TimeOutOn And OnTimeOutFromExternal
OnTimeFlag = Args.TimeOutOn And OnTime
OnWorkBookDeactivationFlag = Args.TimeOutOn And OnWorkBookDeactivation
OnApplicationDeactivationFlag = Args.TimeOutOn And OnApplicationDeactivation
OnUserIdleFlag = Args.TimeOutOn And OnUserIdle
If CDbl(Args.AtDateTime) > 0 Then OnTimeFlag = True
If OnTimeFlag And Args.AtDateTime < Now Then
Err.Raise 10000, "Sub OnTimePlus", "Argument ""AtDateTime"" must be greater than the current date and time."
Exit Function
ElseIf OnTimeFlag = True Then
TimeOutOnTime(0) = Args.AtDateTime
End If
If (Args.Hours + Args.Minutes + Args.Seconds <= 0) Then Args.Seconds = 1
TotalSeconds = (Args.Hours * 36000) + (Args.Minutes * 60) + (Args.Seconds)
TimeOutOnTime(1) = DateAdd("s", TotalSeconds, Now)
If Not OnTimeFlag Then TimeOutOnTime(0) = TimeOutOnTime(1)
MinimumInterval = Application.WorksheetFunction.Min(DateDiff("s", Now, TimeOutOnTime(0)), TotalSeconds)
If MinimumInterval < Args.CheckIntervalSeconds Then Args.CheckIntervalSeconds = Int(MinimumInterval / 10)
If Args.CheckIntervalSeconds = 0 Then Args.CheckIntervalSeconds = 1
RunProcedureName = Args.ProcedureName
AppHwnd = Application.hwnd
' AppHwnd = FindWindow("XLMAIN", Application.Caption)
If OnTimeOutFromExternalFlag Then
OnTimeOutFromExternalPropName = ThisWorkbook.Name
SetProp GetDesktopWindow, OnTimeOutFromExternalPropName, CLng(False)
End If
TimeOutOnTime(1) = Now
TimerCheckIntervalMilliseconds = (Args.CheckIntervalSeconds * 800)
LastInputTickCount = GetTickCount
ResetTimer
StartOnTimePlus = True
Exit Function
Err_OnTimePlus:
If Err.Number = 6 Then
Err.Raise 10002, "Sub OnTimePlus", "Invalid argument."
ElseIf Err.Number = 10000 Or Err.Number = 10004 Then
Err.Raise Err.Number, Err.Source, Err.Description
Exit Function
Else
Debug.Print "Unhandled error in Function OnTimePlus" & Err.Number & ", " & Err.Description
End If
End Function
Private Function ResetVariables()
TimerId = 0
TimerCheckIntervalMilliseconds = 0
TimeOutOnTime(0) = 0
TimeOutOnTime(1) = 0
TotalSeconds = 0
RunProcedureName = ""
OnTimeFlag = False
OnWorkBookDeactivationFlag = False
OnApplicationDeactivationFlag = False
OnUserIdleFlag = False
RemoveProp GetDesktopWindow, OnTimeOutFromExternalPropName
End Function
Function ResetTimer()
TimerId = SetTimer(0, TimerId, TimerCheckIntervalMilliseconds, AddressOf CheckTimeOutStatus)
End Function
Private Function CheckTimeOutStatus(ByVal hwnd As Long, ByVal message As Long, ByVal idTimer As Long, ByVal dwTime As Long) As LongPtr
On Error GoTo Err_CheckTimeOutStatus
If CBool(GetProp(GetDesktopWindow, OnTimeOutFromExternalPropName)) Then
TimedOut
Exit Function
End If
If OnTimeFlag And (Now >= TimeOutOnTime(0)) Then
TimedOut
Exit Function
End If
If OnApplicationDeactivationFlag Then
If GetForegroundWindow = AppHwnd And Application.WindowState <> xlMinimized Then
If Not OnUserIdleFlag Then TimeOutOnTime(1) = Now
Else
If HasTimedOut Then
TimedOut
Exit Function
End If
End If
End If
If OnWorkBookDeactivationFlag Then
If ThisWorkbook Is ActiveWorkbook Then
TimeOutOnTime(1) = Now
Else
If HasTimedOut Then
TimedOut
Exit Function
End If
End If
End If
If OnUserIdleFlag Then
Dim LastInput As LASTINPUTINFO
LastInput.cbSize = Len(LastInput)
If GetLastInputInfo(LastInput) <> 0 Then
If LastInput.dwTime <> LastInputTickCount Then
TimeOutOnTime(1) = Now
Else
If HasTimedOut Then
TimedOut
Exit Function
End If
End If
LastInputTickCount = LastInput.dwTime
End If
End If
Exit Function
Err_CheckTimeOutStatus:
StopOnTimePlus
Debug.Print "Unhandled error in Function CheckTimeOutStatus," & Err.Number & ", " & Err.Description
End Function
Private Function HasTimedOut() As Boolean
If DateDiff("s", TimeOutOnTime(1), Now) >= TotalSeconds Then
HasTimedOut = True
End If
End Function
Private Function TimedOut()
On Error Resume Next
StopOnTimePlus
If RunProcedureName <> "" Then
Application.OnTime Now, RunProcedureName
If Err.Number = 1004 Then
Err.Raise 10003, "Function TimedOut", Err.Description
End If
End If
ResetVariables
End Function
