Auomaticically log out remote users (1 Viewer)

Status
Not open for further replies.

DCrake

Remembered
Local time
Today, 07:48
Joined
Jun 8, 2005
Messages
8,632
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

Code:
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.
 

Attachments

  • AutoLogOut2003.zip
    25.4 KB · Views: 1,425
  • AutoLogOut2007.zip
    46.5 KB · Views: 2,179
Last edited:

rossdagley

New member
Local time
Today, 07:48
Joined
Dec 31, 2010
Messages
2
View Current logged in users to a database

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:
Code:
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
 
Status
Not open for further replies.

Users who are viewing this thread

Top Bottom