Follow along with the video below to see how to install our site as a web app on your home screen.
Note: This feature may not be available in some browsers.
Option Compare Database
Sub ShowUserRosterAndPassiveShutdown()
Dim cn As New ADODB.Connection
Dim cn2 As New ADODB.Connection
Dim cn3 As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim j As Long
On Error GoTo ErrHandler
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open "Data Source=[red]<Backend path\MyBEDB.mdb>[/red]"
cn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=[red]<Backend path\MyBEDB.mdb>[/red]"
' Restrict other users from opening the database
cn.Properties("Jet OLEDB:Connection Control") = 1
' Attempt to open another connection to the database
cn3.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=[red]<Backend path\MyBEDB.mdb>[/red]"
' The user roster is exposed as a provider-specific
' schema rowset in the Jet 4 OLE DB provider. You have to use
' a GUID to reference the schema, as provider-specific schemas
' are not listed in ADO's type library for schema rowsets
Set rs = cn.OpenSchema(adSchemaProviderSpecific, , _
"{947bb102-5d43-11d1-bdbf-00c04fb92675}")
' Output the list of all users in the current database.
Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name
Do While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), _
rs.Fields(2), rs.Fields(3)
rs.MoveNext
Loop
' Close one of the remaining connections
cn2.Close
' Reopen the user roster to verify that no other users are in the
' database Output the list of all users in the current database.
Set rs = cn.OpenSchema(adSchemaProviderSpecific, , _
"{947bb102-5d43-11d1-bdbf-00c04fb92675}")
Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name
Do While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), _
rs.Fields(2), rs.Fields(3)
rs.MoveNext
Loop
cn.Close
Exit Sub
ErrHandler:
For j = 0 To cn.Errors.Count - 1
Debug.Print "Conn Err Num : "; cn.Errors(j).Number
Debug.Print "Conn Err Desc: "; cn.Errors(j).Description
Next j
For j = 0 To cn2.Errors.Count - 1
Debug.Print "Conn Err Num : "; cn2.Errors(j).Number
Debug.Print "Conn Err Desc: "; cn2.Errors(j).Description
Next j
For j = 0 To cn3.Errors.Count - 1
Debug.Print "Conn Err Num : "; cn3.Errors(j).Number
Debug.Print "Conn Err Desc: "; cn3.Errors(j).Description
Next j
Resume Next
End Sub
Option Compare Database
Option Explicit
Dim boolCountDown As Boolean
Dim intCountDownMinutes As Integer
Private Sub Form_Open(Cancel As Integer)
' Set Count Down variable to false
' on the initial opening of the form.
boolCountDown = False
End Sub
Private Sub Form_Timer()
On Error GoTo Err_Form_Timer
Dim strFileName As String
strFileName = Dir("[red]<your backend path>\[/red][green]<checkfile>[/green]")
If boolCountDown = False Then
' Do nothing unless the check file is missing.
If strFileName <> "[green]<checkfile>[/green]" Or strChecFile <> "[green]<checkfile>[/green]" Then
' The check file is not found so
' set the count down variable to true and
' number of minutes until this session
' of Access will be shut down.
boolCountDown = True
intCountDownMinutes = 2
End If
Else
' Count down variable is true so warn
' the user that the application will be shut down
' in X number of minutes. The number of minutes
' will be 1 less than the initial value of the
' intCountDownMinutes variable because the form timer
' event is set to fire every 60 seconds
intCountDownMinutes = intCountDownMinutes - 1
'Close and Save the two main forms
DoCmd.Close acForm, "frmTicketingSystem", acSaveYes
DoCmd.Close acForm, "frmEditLocations", acSaveYes
'Display warning message
DoCmd.OpenForm "frmAppShutDownWarn"
Forms!frmAppShutDownWarn!txtWarning = "Do to immediate maintenance. This application will shutdown in approximately " & intCountDownMinutes & " minute(s). All work will be saved on it's shutdown."
If intCountDownMinutes < 1 Then
' Shut down Access if the countdown is zero,
' saving all work by default.
DoCmd.Close acForm, "frmPutPicture", acSaveYes
SetMDBdefaults
Application.Quit acQuitSaveAll
End If
End If
Exit_Form_Timer:
Exit Sub
Err_Form_Timer:
Resume Next
End Sub
'Close and Save the two main forms
[blue]DoCmd.Close acForm, "frmTicketingSystem", acSaveYes[/blue]
[blue]DoCmd.Close acForm, "frmEditLocations", acSaveYes[/blue]
'Display warning message
[red]DoCmd.OpenForm "frmAppShutDownWarn"
Forms!frmAppShutDownWarn!txtWarning = "Do to immediate maintenance. This application will shutdown in approximately " & intCountDownMinutes & " minute(s). All work will be saved on it's shutdown."[/red]
If intCountDownMinutes < 1 Then
' Shut down Access if the countdown is zero,
' saving all work by default.
DoCmd.Close acForm, "frmPutPicture", acSaveYes