Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Table: [CurrentConnections]
- computerName Text(255), Primary Key
- Table: [ConnectionLog]
- computerName Text(255), Primary Key
- userName Text(255)
- Public Sub GetCurrentlyConnectedMachines()
- Dim cdb As DAO.Database, rst As DAO.Recordset
- Dim fso As Object '' FileSystemObject
- Dim lck As Object '' ADODB.Stream
- Dim lockFileSpec As String, lockFileExt As String, tempFileSpec As String
- Dim buffer() As Byte
- Set cdb = CurrentDb
- cdb.Execute "DELETE FROM CurrentConnections", dbFailOnError
- Set rst = cdb.OpenRecordset("SELECT computerName FROM CurrentConnections", dbOpenDynaset)
- lockFileSpec = Application.CurrentDb.Name
- If Right(lockFileSpec, 6) = ".accdb" Then
- lockFileExt = ".laccdb"
- Else
- lockFileExt = ".ldb"
- End If
- lockFileSpec = Left(lockFileSpec, InStrRev(lockFileSpec, ".", -1, vbBinaryCompare) - 1) & lockFileExt
- '' ADODB.Stream cannot open the lock file in-place, so copy it to %TEMP%
- Set fso = CreateObject("Scripting.FileSystemObject") '' New FileSystemObject
- tempFileSpec = fso.GetSpecialFolder(2) & "" & fso.GetTempName
- fso.CopyFile lockFileSpec, tempFileSpec, True
- Set lck = CreateObject("ADODB.Stream") '' New ADODB.Stream
- lck.Type = 1 '' adTypeBinary
- lck.Open
- lck.LoadFromFile tempFileSpec
- Do While Not lck.EOS
- buffer = lck.Read(32)
- rst.AddNew
- rst!computerName = DecodeSZ(buffer)
- rst.Update
- buffer = lck.Read(32) '' skip accessUserId, (almost) always "Admin"
- Loop
- lck.Close
- Set lck = Nothing
- rst.Close
- Set rst = Nothing
- Set cdb = Nothing
- fso.DeleteFile tempFileSpec
- Set fso = Nothing
- End Sub
- Private Function DecodeSZ(buf() As Byte) As String
- Dim b As Variant, rt As String
- rt = ""
- For Each b In buf
- If b = 0 Then
- Exit For '' null terminates the string
- End If
- rt = rt & Chr(b)
- Next
- DecodeSZ = rt
- End Function
- Private Sub Form_Load()
- Dim cdb As DAO.Database, rst As DAO.Recordset
- Dim wshNet As Object '' WshNetwork
- Set wshNet = CreateObject("Wscript.Network")
- Set cdb = CurrentDb
- Set rst = cdb.OpenRecordset("SELECT * FROM ConnectionLog", dbOpenDynaset)
- rst.FindFirst "ComputerName=""" & wshNet.computerName & """"
- If rst.NoMatch Then
- rst.AddNew
- rst!computerName = wshNet.computerName
- Else
- rst.Edit
- End If
- rst!userName = wshNet.userName
- rst.Update
- Set wshNet = Nothing
- End Sub
- SELECT CurrentConnections.computerName, ConnectionLog.userName
- FROM CurrentConnections LEFT JOIN ConnectionLog
- ON CurrentConnections.computerName = ConnectionLog.computerName
- ORDER BY ConnectionLog.userName;
- Private Sub Form_Load()
- UpdateFormData
- End Sub
- Private Sub cmdRefresh_Click()
- UpdateFormData
- End Sub
- Private Sub UpdateFormData()
- GetCurrentlyConnectedMachines
- Me.Requery
- End Sub
- Private Sub Form_Unload(Cancel As Integer)
- Dim wshNet As Object
- Dim deleteSQL As String
- Set wshNet = CreateObject("WScript.Network")
- DoCmd.SetWarnings False
- deleteSQL = "DELETE tblCurrentConnections.* " & _
- "FROM tblCurrentConnections WHERE[computerName] = '" & wshNet.computerName & "';"
- DoCmd.RunSQL deleteSQL
- DoCmd.SetWarnings True
- End Sub
Add Comment
Please, Sign In to add comment