There might be occasion where you want to have a time on your Microsoft Access Database 365. On my case we have a timer of 5' that pops up a scary window after that amount of inactivity, and it automatically closes the database saving all the work, cool ah?

First of all create a Form called "frmInactiveShutdown", I designed like this:

 

Still on the design section of the form, click on the big square to open the Properties Sheet, visit the "Event" tab, and on the field On Open, select Event Procedure, then click on the 3 dots next to it...

 

That will open Microsoft Visual Basic, with the entry for the form, paste on the form all this code below:

 

Option Compare Database
Option Explicit
'  frmInactiveShutDown v2.3 for MS Access from Peter's Software
'    v3.0 Access 2010 64-bit compatibility
'    v2.3 includes a "On Error GoTo 0" at the bottom of the timer routine
'
'  Copyright: Peter's Software 2001-2010 :: http://www.peterssoftware.com
'
'  Description:
'    A form that monitors user activity and automatically shuts down the application after
'    a specified period of inactivity.
'
'  This module was created by:
'
'    Peter's Software
'    This email address is being protected from spambots. You need JavaScript enabled to view it.
'    http://www.peterssoftware.com
'
'  Special thanks to
'    Stefano Sarasso
'
'  This form and associated code are distributed as freeware
'
'  Usage
'
'    Import the form frmInactiveShutDown into your application and open it hidden at application startup.
'
'    Set the inactivity period by adjusting values in the form OnOpen event procedure.
'
'    Optionally include the basISDOptionalModule to take advantage of a global variable that is set
'    to True when an Inactive Timeout occurs.
'


'* Set this constant to True if you want the ISD form to pop up in front of other
'* application windows when an Inactive Timeout occurs.
Const conPopUpISDFormForeground = True

Const conSeconndsPerMinute = 60
Dim sngStartTime As Single
Dim ctlSave As Control
Dim intMinutesUntilShutDown As Integer
Dim intMinutesWarningAppears As Integer
Private Const SW_RESTORE = 9
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_SHOWWINDOW = &H40
Private Const HWND_TOP = 0
Private Const HWND_TOPMOST = -1

'v3.0 - Access 2010 64-bit compatibility
#If VBA7 Then
    Private Declare PtrSafe Function SetForegroundWindow& Lib "user32" (ByVal hwnd As LongPtr)
    Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
#Else
    Private Declare Function SetForegroundWindow& Lib "user32" (ByVal hwnd As Long)
    Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
#End If
Private Function xg_CallIfPresent(pstrFunctionNameAndParms As String) As Integer
'* Call a function using the Eval function.
'* This method allows us to call a function whether it exists or not.
'*
'* Returns
'*   1 - Function found, executed, and returns True
'*   2 - Function found, executed, and returns False
'*   3 - Function not found
'*   99 - Other error

Dim intRtn As Integer

On Error Resume Next
If Eval(pstrFunctionNameAndParms) Then
    If err <> 0 Then
        Select Case err
        Case 2425, 2426
            intRtn = 3     '* The function is not found
        Case Else
            MsgBox "Error in xg_CallIfPresent when calling '" & pstrFunctionNameAndParms & "': " & err.Number & " - " & err.Description
            intRtn = 99     '* Other error
        End Select
        err.Clear
    Else
        intRtn = 1  '* Function evaluates to True
    End If
Else
    intRtn = 2  '* Function evaluates to False
End If

Exit_Section:
    On Error Resume Next
    xg_CallIfPresent = intRtn
    On Error GoTo 0
    Exit Function
Err_Section:
    Beep
    MsgBox "Error in xg_CallIfPresent: " & err.Number & " - " & err.Description
    err.Clear
    Resume Exit_Section

End Function



Private Sub Form_Close()
On Error Resume Next
ctlSave = Nothing
err.Clear
On Error GoTo 0
End Sub

Private Sub Form_Open(Cancel As Integer)

'* Set this variable to the number of minutes of inactivity
'* allowed before the application automatically shuts down.
'intMinutesUntilShutDown = 20
intMinutesUntilShutDown = 10

'* Set this variable to the number of minutes that the
'* warning form will appear before the application
'* automatically shuts down.
intMinutesWarningAppears = 5
'intMinutesWarningAppears = 2

Me.Visible = False
sngStartTime = Timer
End Sub

Private Sub Form_Timer()
'**********************************************************************
'* This timer event procedure will shut down the application
'* after a specified number of minutes of inactivity. Inactivity
'* is measured based on how long a control remains the ActiveControl.
'**********************************************************************
Dim sngElapsedTime As Single
Dim ctlNew As Control
Dim i As Integer
Dim FN(20) As String
On Error Resume Next

'If Time() > #5:00:00 PM# Then  '* Uncomment this to have ISD start at a particular time of day
Set ctlNew = Screen.ActiveControl
If err <> 0 Then
    '* No activecontrol
    'pddxxx need to use datediff("s" ... here because timer resets at midnight
    ' find difference in seconds
    sngElapsedTime = Timer - sngStartTime
    err.Clear
Else
    If ctlNew.Name = "InactiveShutDownCancel" Then
        '* The warning form has appeared, and the cancel button
        '* is the active control
        sngElapsedTime = Timer - sngStartTime
    Else
        If ctlNew.Name = ctlSave.Name Then
            '* Still at same control
            sngElapsedTime = Timer - sngStartTime
        Else
            '* Some change has occured, we're at a new control
            Set ctlSave = ctlNew
            sngStartTime = Timer
        End If
        If err <> 0 Then
            Set ctlSave = Screen.ActiveControl
        End If
    End If
End If
err.Clear
'Else
'    sngElapsedTime = 0
'End If

Set ctlNew = Nothing

Select Case sngElapsedTime
Case Is > (intMinutesUntilShutDown * conSeconndsPerMinute)
    '* Set global timeout variable, then shut down each form
    '* This code can be used if there is code in the form's BeforeUpdate,
    '* or OnClose event procedure that requires user input.
    '* The variable "gintInactiveTimeout" can be checked in the form events
    '* and can be used to prevent the user prompt code from executing.
    Dim frm As Form
    
    '* Set the global variable "gintInactiveTimeout" to True if the basISDOptionalModule is included
    Select Case xg_CallIfPresent("isd_SetInactiveTimeoutVar(True)")
    Case 1, 2, 3, 99
        '* We'll accept the results regardless of the return code
    Case Else
    End Select
    
    '* Close all forms
    For i = 0 To 20
        FN(i) = ""
    Next i
    i = 0
    '* Find all open form names
    For Each frm In Forms
        If i > 20 Then
            Exit For
        End If
        If frm.Name = "frmInactiveShutDown" Then
        Else
            FN(i) = frm.Name
            i = i + 1
        End If
    Next frm
    '* Now close them all
    For i = 0 To 20
        If FN(i) = "" Then
        Else
            'MsgBox "Closing " & FN(i)
            DoCmd.Close acForm, FN(i), acSaveYes
        End If
    Next i
    
    '* Set the global variable "gintInactiveTimeout" to False if the basISDOptionalModule is included
    Select Case xg_CallIfPresent("isd_SetInactiveTimeoutVar(False)")
    Case 1, 2, 3, 99
        '* We'll accept the results regardless of the return code
    Case Else
    End Select
    
    Set frm = Nothing
    
    Set ctlSave = Nothing
    DoCmd.Quit acQuitSaveAll
Case Is > ((intMinutesUntilShutDown - intMinutesWarningAppears) * conSeconndsPerMinute)
    '* Make the warning form visible if it is not already visible.
    If Me.Visible Then
    Else
        Me.Visible = True
        
        If conPopUpISDFormForeground Then
            '* Un-minimize Access application if it is minimized
            If IsIconic(Application.hWndAccessApp) Then
                ShowWindow Application.hWndAccessApp, SW_RESTORE
            End If
            '* Make it the foreground window - open it in front of other application windows.
            SetForegroundWindow (Me.hwnd)
        End If
        
        '* Open it on top of other modal windows.
        SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW
    End If
Case Else
    '* The next line can be commented out if the form is opened hidden
    'Me.Visible = False
End Select

Exit_Section:
    On Error Resume Next
    On Error GoTo 0
End Sub


Private Sub InactiveShutDownCancel_Click()
sngStartTime = Timer
Me.Visible = False
End Sub


Finally, create a macro called "AutoExec" and set it to open the form (so that the countdown will start) but on hidden mode

 

To make it all work, do as follows:

  1. Visit File > Options > Current Database > and set a form to open when you open the database, for example a form called "Home"
  2. Create a macro that maximises a window form, then on the Home form, go to Design and set the onLoad action to that maximese macro
  3. Set the On Open of the form to the "AutoExec" macro, so that whenever the database is open, the shutdown form loads hidden in the background

 

 

Hope that helps!

Good luck

 

 

 

Print Friendly, PDF & Email

Comments powered by CComment