Detect User Inactivity 64-bit Update

gravanoc

Active Member
Joined
Oct 20, 2015
Messages
351
Office Version
  1. 365
Platform
  1. Windows
  2. 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:

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 Function

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
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 Function


Standard 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
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
The following update should work across all bit platforms

VBA Code:
Option Explicit

'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

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongLong
    #Else
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    #End If
    Private Declare PtrSafe Function GetLastInputInfo Lib "user32.dll" (plii As LASTINPUTINFO) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    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 LastInputTickCount As LongPtr
  #Else
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    Private Declare Function GetLastInputInfo Lib "user32.dll" (plii As LASTINPUTINFO) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetForegroundWindow Lib "user32" () As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    
    Private LastInputTickCount As Long
#End If

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 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

    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 = CLng(SetTimer(0, TimerId, TimerCheckIntervalMilliseconds, AddressOf CheckTimeOutStatus))
End Function

Private Function CheckTimeOutStatus(ByVal hwnd As LongPtr, 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
 
Upvote 0
Solution
@Jaafar Tribak do you know a good way to stop the processes from running when other code is running? It has been crashing when I'm trying to debug code or if it coincides with another routine running. Thanks again.
 
Upvote 0
do you know a good way to stop the processes from running when other code is running? It has been crashing when I'm trying to debug code or if it coincides with another routine running. Thanks again.

I think the culprit is the writer of that code (Tom Schneider) stored the windows timer ID in a variable which can easily be lost when debugging or when a state loss of the vbproject occures.

Find below an amendment of his code which doesn't rely on a Timer ID. We can do without the Timer ID just by associating it to a window HWND (ie: Application.hwnd) . This is possible because we are lucky there is only one timer running at anyone time.

Give it a go and let us know the outcome.
VBA Code:
Option Explicit

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

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongLong
    #Else
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    #End If
    Private Declare PtrSafe Function GetLastInputInfo Lib "user32.dll" (plii As LASTINPUTINFO) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    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 LastInputTickCount As LongPtr
  #Else
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    Private Declare Function GetLastInputInfo Lib "user32.dll" (plii As LASTINPUTINFO) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetForegroundWindow Lib "user32" () As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
   
    Private LastInputTickCount As Long
#End If

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 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
        Call KillTimer(Application.hwnd, 0)
'    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

    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 = CLng(SetTimer(0, TimerId, TimerCheckIntervalMilliseconds, AddressOf CheckTimeOutStatus))
'End Function
Function ResetTimer()
    Call KillTimer(Application.hwnd, 0)
    Call SetTimer(Application.hwnd, 0, TimerCheckIntervalMilliseconds, AddressOf CheckTimeOutStatus)
End Function

Private Function CheckTimeOutStatus(ByVal hwnd As LongPtr, 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

Important notice:
BTW, there is also another shortcoming in that code, that is, if excel is in Edit Mode when the Time out is over , the inactive workbook won't be able to auto-close. The same problem occurs if there happens to be a MsgBox, a UserForm or an excel Dialog open when the time out is over.
 
Upvote 0
Awesome, I'll give it a try. It's pretty useful to help keep track of time spent using a spreadsheet, so I don't believe that issue with the auto-close will be in play for me.
 
Upvote 0

Forum statistics

Threads
1,224,247
Messages
6,177,406
Members
452,774
Latest member
Macca1962

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