Current Users in Access 2007

[psamu]

I am trying to look for who logged in the database but giving error. below is the code:

Option Compare Database
'********************************************************************************************************
'This module, when placed within an existing database will check for the existance
'of a text file in the current project path. If the file is found it opens the file
'and reads in the line of text to display as a message in a mesage box.
'If a user attempts to open the database the message box will tell them that the database
'is currently unavailable due to system administration purposes and that they should try
'again later.
'This prevents users who have been asked to log out of an application re opening it before
'the routine maintenance has been carried out.
'As the administrator of the system simply delete this file from the project path.
'This will also work if the attributes of the file has been set to hidden.
'To invoke this functionality place the following command line in the startup form of your application
'On the ****** Event
'Don't forget to copy this module into the mdb that you want to use it in

'NOTE:This feature will only work on a Front End application
'Call LockedOut
'********************************************************************************************************

Public Function LockedOut()
If Dir(CurrentProject.Path & "\Locked.Txt") = "" Then
'File does not exist, file access granted
Exit Function
End If
Dim strMsg As String
Open CurrentProject.Path & "\Locked.Txt" For Input As #1
Line Input #1, strMsg
Close #1
MsgBox strMsg, vbExclamation + vbOKOnly, "System Admimistrator"
DoCmd.Quit

End Function



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 Rst As DAO.Recordset

Dim i, j As Long
Dim StrComp As String
Dim StrUser As String
StrWhereAmI = Me.TxtPath

Set Rst = CurrentDb.OpenRecordset("TblSession")
With cn
.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & Me.TxtPath & "\" & Me.TxtFile
' 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
End With
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 (*.accdb)|*.accdb"
'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