Here is a simple demo that can log out remote users.

I have included some points on the opening form, however the one thing to point out is that the apllication needs to have an application icon.


In the demo the routine is looking for a text file in the current project path however in real time this file needs to be in the same folder on the shared location wher the back end resides. This way you only need to publish the Lock.txt file to one location that all logged in users can see.

Hope you like it and any comments you may have will be welcome.

I have included an icon in the zip file and to get it to work straightway save the accdb to C:\AutoLogOut

All you need to do is import the module and class into your front end and the sample form. Then copy the form module into your main menu form.


As an added feature if you use the following code in the OnLoad Event of your splash screen this will prevent the user from reopeing the database

If Dir("YourBackEndPathHere\Lock.Txt") <> "" Then
MsgBox "The database is currently unavailable for routine maintenance",vbInformation+vbOkOnly,"Application under development"
DoCmd.Quit
End If

Then when you have finished your work on the database you simply delete the Lock.Txt file or rename it to Free.txt.

Further to David's excellent post I have modified the functions to work with Access 2007 - I hope it's useful to others also.

I am unable to post the modified MDB due to low post count (lurker not poster) but here is the modified function if someone with admin rights on the forum want's to edit David's original example.

Replace Form_FrmCurrentUsers source with:

Option Compare Database
'Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Function ShowUserRosterMultipleUsersLocal()

Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim Rst As DAO.Recordset

Dim i, j As Long
Dim StrComp As String
Dim StrUser As String
StrWhereAmI = CurrentProject.Path


Set cn = CurrentProject.Connection
Set Rst = CurrentDb.OpenRecordset("TblSession")
' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4.0 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}")
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete * From TblSession"

While Not rs.EOF
Rst.AddNew
Rst.Fields(0) = rs.Fields(0)
Rst.Fields(1) = rs.Fields(1)
Rst.Fields(2) = rs.Fields(2)
Rst.Update
rs.MoveNext
Wend
DoCmd.SetWarnings True
Set Rst = Nothing
DoEvents
Me.List0.RowSource = "QryCurrentUsers"
End Function
Function ShowUserRosterMultipleUsersRemote()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, j As Long
Dim StrComp As String
Dim StrUser As String

Set cn = CurrentProject.Connection

StrWhereAmI = Me.TxtPath

Set Rst = CurrentDb.OpenRecordset("TblSession")
Set cn = CurrentProject.Connection
Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")


DoCmd.SetWarnings False
DoCmd.RunSQL "Delete * From TblSession"

While Not rs.EOF
Rst.AddNew
Rst.Fields(0) = rs.Fields(0)
Rst.Fields(1) = rs.Fields(1)
Rst.Fields(2) = rs.Fields(2)
Rst.Update
rs.MoveNext
Wend
DoCmd.SetWarnings True
Set Rst = Nothing
DoEvents
Me.List0.RowSource = "QryCurrentUsers"
End Function


Private Sub CmdBrowse_Click()
Dim LastSlash As Integer

Me.CmDlg.InitDir = CurrentProject.Path
Me.CmDlg.Filter = "Microsoft Access Database (*.mdb)|*.mdb"

Me.CmDlg.ShowOpen
Me.TxtPath = Me.CmDlg.FileName
LastSlash = InStrRev(Me.CmDlg.FileName, "\")

Me.TxtPath = Left(Me.CmDlg.FileName, LastSlash - 1)

Me.TxtFile = Mid(Me.CmDlg.FileName, LastSlash + 1)

End Sub

Private Sub CmdLock_Click()
If Me.CmdLock.Caption = "Lock Database" Then
Dim strMsg As String
If Nz(Me.TxtFile, "") = "" Then
StrWhereAmI = CurrentProject.Path
Else
StrWhereAmI = Me.TxtPath
End If

strMsg = InputBox("What message do you want to show the user?", "System Down Message")
If strMsg = "" Then
Exit Sub
End If
Open StrWhereAmI & "\Locked.Txt" For Output As #1
Print #1, strMsg
Close #1

Me.CmdLock.Caption = "Unlock Database"
Else
If Dir(StrWhereAmI & "\Locked.Txt") <> "" Then
Kill StrWhereAmI & "\Locked.Txt"
End If
Me.CmdLock.Caption = "Lock Database"
End If



End Sub

Private Sub CmdReset_Click()
Me.TxtPath = ""
Me.TxtFile = ""
Me.List0.RowSource = ""
Me.List0.Requery

End Sub

Private Sub CmdRetry_Click()
Me.List0.RowSource = ""
Me.List0.Requery

If Nz(Me.TxtFile, "") = "" Then
Call ShowUserRosterMultipleUsersLocal
Else
Call ShowUserRosterMultipleUsersRemote
End If
End Sub

Private Sub CmdClose_Click()
On Error GoTo Err_CmdClose_Click


DoCmd.Close

Exit_CmdClose_Click:
Exit Sub

Err_CmdClose_Click:
MsgBox Err.Description
Resume Exit_CmdClose_Click

End Sub

Public Function FindComputerName()
Dim strBuffer As String
Dim lngSize As Long

strBuffer = String(100, " ")
lngSize = Len(strBuffer)

If GetComputerName(strBuffer, lngSize) = 1 Then
FindComputerName = Left(strBuffer, lngSize)
Else
FindComputerName = "Computer Name not available"
End If

End Function

Private Sub Form_Load()
Call LockedOut
End Sub

Private Sub List0_Click()
Me.CmdSend.Enabled = True
Me.CmdDisconnect.Enabled = True
End Sub