Hi All,
I found this cool database created by Brent Spalding - Who's Connected.mdb @ but I'm struggling to get the code to read Environ("USERNAME") instead of giving me Admin for the Access Login Name. Has anyone done this?
Brent's code -
'''''''''''''''''''''''''''''''''''''''
'Author: Brent Spaulding
'Date: 1/2005
'Version: 1.0
'''''''''''''''''''''''''''''''''''''''
'Copyright:
'The procedures in this module are authored by me using Ideas
'and code snippets from public resources available like UtterAccess.com
'or the MicroSoft knowledge base. As the distributor and primary author
'of this Module, I welcome you to use it in your application, however, you
'MUST NOT gain financially from the use or inclusion of this module or the code,
'within it in whole or in part, with out my permission! ..
'If you use my code in your application, then please give credit where credit
'is do. If you want to use my code in a commercial (for profit) application
'(ie: something someone spends money on), her is how to contact me ...
'datadrenaline@aol.com, or at userID datAdrenaline.
'Thanks for your honesty and cooperation ... Brent Spaulding
'''''''''''''''''''''''''''''''''''''''
'Module
'Version Info:
'1.0 Initial Release
'1.1 Modified GetMDBUserLog the function was ALWAYS returning TRUE, now it
' returns False if an error is generated and True is no error is generated
' Also, added ability to connect to a wrkgrp protected file and/or db pwd
' protected file.
Option Explicit ' Require variables to be declared before being used.
Option Compare Database ' Use database order for string comparisons.
'Constants
Private Const mconTblConnectedUsers = "tblConnectedUsers"
'User Log Options
Public Enum wloOnRefresh
wloRfDeleteAll = 1
wloRfUpdateExisting = 2
wloRfAlwaysAppend = 3
End Enum
'Persistent Objects
Public cnnDatafile As ADODB.Connection 'Connection to the file be analyzed
Public Function GetMDBLoggedUsers(strFileName As String, _
Optional blForceReconnect As Boolean = False, _
Optional wloRfLogOption As wloOnRefresh = wloRfUpdateExisting, _
Optional blViewErrors As Boolean = True, _
Optional strWorkGroupFile As String = "", _
Optional strUserID As String = "", _
Optional strPassword As String = "", _
Optional strDatabasePassword As String) As Boolean
'Get the logged users from the .MDB file
'Returns TRUE if no errors were generated
Static strPreviousFile As String 'Track that last file examined
Dim rstConnectedUsers As New ADODB.Recordset 'Pointer to the local table
Dim rstUserRoster As ADODB.Recordset 'The "UserRoster" recordset in the MDB
'Field names: COMPUTER_NAME,LOGIN_NAME,CONNECTED,SUSPECT_STATE
Dim strComputerName As String 'Field value of User Roster
Dim strLoginName As String 'Field value of User Roster
Dim blIsConnected As Boolean 'Field value of User Roster
Dim strSuspectState As String 'Field value of User Roster
Dim dtTimestamp As Date 'The time this code was ran and what the records
'will be stamped with
On Error GoTo Error_Handler:
'Init
dtTimestamp = Now()
GetMDBLoggedUsers = False 'Assume the worst, upon success, will be set to true
'Establish the connection & user roster if needed
If blForceReconnect = True Or _
cnnDatafile Is Nothing Or _
strPreviousFile <> strFileName Then
'Close the persistent connection and set to nothing
If Not cnnDatafile Is Nothing Then
If cnnDatafile.State = adStateOpen Then
cnnDatafile.Close
End If
Set cnnDatafile = Nothing
End If
'Establish the connection and set the persisent connection
Set cnnDatafile = New ADODB.Connection
cnnDatafile.Provider = "Microsoft.Jet.OLEDB.4.0"
cnnDatafile.CursorLocation = adUseClient
'Set the database password to use
If Len(Trim(strDatabasePassword)) > 0 Then
cnnDatafile.Properties("Jet OLEDB
atabase Password") = strDatabasePassword
End If
'Set the workgroup file, user id, and password
If Len(Trim(strWorkGroupFile)) > 0 Then
If Len(Trim(strUserID)) = 0 Or Len(Trim(strPassword)) = 0 Then
MsgBox "If you specify a Work Group, then you need a UserID and Password!", vbCritical
GetMDBLoggedUsers = False
GoTo Clean_Up
Else
cnnDatafile.Properties("Jet OLEDB:System database") = strWorkGroupFile
cnnDatafile.Properties("User ID") = strUserID
cnnDatafile.Properties("Password") = strPassword
End If
End If
'Open the data source
cnnDatafile.Open "Data Source=" & strFileName
'Remeber the file name
strPreviousFile = strFileName
Else
'Do Nothing
End If
'Open the user roster
' 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 rstUserRoster = cnnDatafile.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
'Open the local connected users log table
rstConnectedUsers.Open mconTblConnectedUsers, CurrentProject.Connection, adOpenDynamic, adLockPessimistic
'Manipulate the local connected users table for the appropriate action
Select Case wloRfLogOption
Case wloRfDeleteAll
'Delete all records in the connected users table
CurrentDb.Execute "DELETE * FROM " & mconTblConnectedUsers, dbFailOnError
Case wloRfUpdateExisting
'Assume and Mark all computers as NOT connected
CurrentDb.Execute "UPDATE " & mconTblConnectedUsers & _
" SET Connected = False", dbFailOnError
Case Else
'Do nothing
End Select
'Loop through the User Roster and modify the Connected Users table
Do Until rstUserRoster.EOF
'Get the values from the current user roster record
strComputerName = Trim(RemCode(Nz(rstUserRoster.Fields("COMPUTER_NAME"), "NULL"), Asc(vbNullChar)))
strLoginName = Trim(RemCode(Nz(rstUserRoster.Fields("LOGIN_NAME"), "NULL"), Asc(vbNullChar)))
blIsConnected = Nz(rstUserRoster.Fields("CONNECTED"), False)
strSuspectState = Trim(RemCode(CStr(Nz(rstUserRoster.Fields("SUSPECT_STATE"), "NULL")), Asc(vbNullChar)))
'Add/Update/Append record to the local table of logged users
With rstConnectedUsers
Select Case wloRfLogOption
Case wloRfAlwaysAppend, wloRfDeleteAll
'Move to the EOF cursor position, not needed, but personal preference
If Not .EOF Then
.MoveLast
.MoveNext
End If
'Add a new record
.AddNew
!ComputerName = strComputerName
Case wloRfUpdateExisting
'Move to the first record then find the current computer
If Not (.BOF And .EOF) Then
.MoveFirst
End If
.Find "ComputerName = '" & strComputerName & "'", , adSearchForward
'Add the record if find is unsuccessful
If .EOF Then
.AddNew
!ComputerName = strComputerName
End If
Case Else
'Do Nothing
End Select
'Now the cursor of rstConnectedUsers is on a New record OR on an existing record
'so now set the fields COMMON to an ADD or an UPDATE accordingly
!WorkGroupUser = strLoginName
!Connected = blIsConnected
!SuspectedState = strSuspectState
!Timestamp = dtTimestamp
.Update
End With 'rstConnectedUsers
'Move to the next MDB user record
rstUserRoster.MoveNext
Loop 'rstUserRoster
'Return the result ... if the code makes it to here, then no errors were generated
GetMDBLoggedUsers = True
'Clean Up
Clean_Up:
On Error Resume Next
If Not rstConnectedUsers Is Nothing Then
If rstConnectedUsers.State = adStateOpen Then rstConnectedUsers.Close
Set rstConnectedUsers = Nothing
End If
If Not rstUserRoster Is Nothing Then
If rstUserRoster.State = adStateOpen Then rstUserRoster.Close
Set rstUserRoster = Nothing
End If
Exit Function
Error_Handler:
'Display the errors if needed
If blViewErrors = True Then
MsgBox Err.Description & " (" & Err.Number & ")", vbExclamation
End If
'Clear the error and close the connection
Err.Clear
On Error Resume Next
If Not cnnDatafile Is Nothing Then
If cnnDatafile.State = adStateOpen Then cnnDatafile.Close
Set cnnDatafile = Nothing
End If
'Set the return value
GetMDBLoggedUsers = False
Resume Clean_Up
End Function
Public Function RemCode(strText, ParamArray intAsciiCodes()) As String
'Removes special characters from a string.
Dim X As Integer
Dim Y As Integer
Dim strX As String
Dim strStrippedText As String
Dim blCodeMatch As Boolean
'Start with the string
strText = Nz(Trim(strText))
'Loop through each digit of the string to determine if is an ASCII code to remove
For X = 1 To Len(strText)
strX = Mid(strText, X, 1)
'Look for a match in ascii codes to the passed parameters
blCodeMatch = False
For Y = 0 To UBound(intAsciiCodes())
If Asc(strX) = CInt(intAsciiCodes(Y)) Then
blCodeMatch = True
Exit For
End If
Next Y
'Add to the stripped text if there is not a match
If Not blCodeMatch Then
strStrippedText = strStrippedText & strX
End If
Next X
RemCode = strStrippedText
End Function
I found this cool database created by Brent Spalding - Who's Connected.mdb @ but I'm struggling to get the code to read Environ("USERNAME") instead of giving me Admin for the Access Login Name. Has anyone done this?
Brent's code -
'''''''''''''''''''''''''''''''''''''''
'Author: Brent Spaulding
'Date: 1/2005
'Version: 1.0
'''''''''''''''''''''''''''''''''''''''
'Copyright:
'The procedures in this module are authored by me using Ideas
'and code snippets from public resources available like UtterAccess.com
'or the MicroSoft knowledge base. As the distributor and primary author
'of this Module, I welcome you to use it in your application, however, you
'MUST NOT gain financially from the use or inclusion of this module or the code,
'within it in whole or in part, with out my permission! ..
'If you use my code in your application, then please give credit where credit
'is do. If you want to use my code in a commercial (for profit) application
'(ie: something someone spends money on), her is how to contact me ...
'datadrenaline@aol.com, or at userID datAdrenaline.
'Thanks for your honesty and cooperation ... Brent Spaulding
'''''''''''''''''''''''''''''''''''''''
'Module
'Version Info:
'1.0 Initial Release
'1.1 Modified GetMDBUserLog the function was ALWAYS returning TRUE, now it
' returns False if an error is generated and True is no error is generated
' Also, added ability to connect to a wrkgrp protected file and/or db pwd
' protected file.
Option Explicit ' Require variables to be declared before being used.
Option Compare Database ' Use database order for string comparisons.
'Constants
Private Const mconTblConnectedUsers = "tblConnectedUsers"
'User Log Options
Public Enum wloOnRefresh
wloRfDeleteAll = 1
wloRfUpdateExisting = 2
wloRfAlwaysAppend = 3
End Enum
'Persistent Objects
Public cnnDatafile As ADODB.Connection 'Connection to the file be analyzed
Public Function GetMDBLoggedUsers(strFileName As String, _
Optional blForceReconnect As Boolean = False, _
Optional wloRfLogOption As wloOnRefresh = wloRfUpdateExisting, _
Optional blViewErrors As Boolean = True, _
Optional strWorkGroupFile As String = "", _
Optional strUserID As String = "", _
Optional strPassword As String = "", _
Optional strDatabasePassword As String) As Boolean
'Get the logged users from the .MDB file
'Returns TRUE if no errors were generated
Static strPreviousFile As String 'Track that last file examined
Dim rstConnectedUsers As New ADODB.Recordset 'Pointer to the local table
Dim rstUserRoster As ADODB.Recordset 'The "UserRoster" recordset in the MDB
'Field names: COMPUTER_NAME,LOGIN_NAME,CONNECTED,SUSPECT_STATE
Dim strComputerName As String 'Field value of User Roster
Dim strLoginName As String 'Field value of User Roster
Dim blIsConnected As Boolean 'Field value of User Roster
Dim strSuspectState As String 'Field value of User Roster
Dim dtTimestamp As Date 'The time this code was ran and what the records
'will be stamped with
On Error GoTo Error_Handler:
'Init
dtTimestamp = Now()
GetMDBLoggedUsers = False 'Assume the worst, upon success, will be set to true
'Establish the connection & user roster if needed
If blForceReconnect = True Or _
cnnDatafile Is Nothing Or _
strPreviousFile <> strFileName Then
'Close the persistent connection and set to nothing
If Not cnnDatafile Is Nothing Then
If cnnDatafile.State = adStateOpen Then
cnnDatafile.Close
End If
Set cnnDatafile = Nothing
End If
'Establish the connection and set the persisent connection
Set cnnDatafile = New ADODB.Connection
cnnDatafile.Provider = "Microsoft.Jet.OLEDB.4.0"
cnnDatafile.CursorLocation = adUseClient
'Set the database password to use
If Len(Trim(strDatabasePassword)) > 0 Then
cnnDatafile.Properties("Jet OLEDB
atabase Password") = strDatabasePasswordEnd If
'Set the workgroup file, user id, and password
If Len(Trim(strWorkGroupFile)) > 0 Then
If Len(Trim(strUserID)) = 0 Or Len(Trim(strPassword)) = 0 Then
MsgBox "If you specify a Work Group, then you need a UserID and Password!", vbCritical
GetMDBLoggedUsers = False
GoTo Clean_Up
Else
cnnDatafile.Properties("Jet OLEDB:System database") = strWorkGroupFile
cnnDatafile.Properties("User ID") = strUserID
cnnDatafile.Properties("Password") = strPassword
End If
End If
'Open the data source
cnnDatafile.Open "Data Source=" & strFileName
'Remeber the file name
strPreviousFile = strFileName
Else
'Do Nothing
End If
'Open the user roster
' 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 rstUserRoster = cnnDatafile.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
'Open the local connected users log table
rstConnectedUsers.Open mconTblConnectedUsers, CurrentProject.Connection, adOpenDynamic, adLockPessimistic
'Manipulate the local connected users table for the appropriate action
Select Case wloRfLogOption
Case wloRfDeleteAll
'Delete all records in the connected users table
CurrentDb.Execute "DELETE * FROM " & mconTblConnectedUsers, dbFailOnError
Case wloRfUpdateExisting
'Assume and Mark all computers as NOT connected
CurrentDb.Execute "UPDATE " & mconTblConnectedUsers & _
" SET Connected = False", dbFailOnError
Case Else
'Do nothing
End Select
'Loop through the User Roster and modify the Connected Users table
Do Until rstUserRoster.EOF
'Get the values from the current user roster record
strComputerName = Trim(RemCode(Nz(rstUserRoster.Fields("COMPUTER_NAME"), "NULL"), Asc(vbNullChar)))
strLoginName = Trim(RemCode(Nz(rstUserRoster.Fields("LOGIN_NAME"), "NULL"), Asc(vbNullChar)))
blIsConnected = Nz(rstUserRoster.Fields("CONNECTED"), False)
strSuspectState = Trim(RemCode(CStr(Nz(rstUserRoster.Fields("SUSPECT_STATE"), "NULL")), Asc(vbNullChar)))
'Add/Update/Append record to the local table of logged users
With rstConnectedUsers
Select Case wloRfLogOption
Case wloRfAlwaysAppend, wloRfDeleteAll
'Move to the EOF cursor position, not needed, but personal preference
If Not .EOF Then
.MoveLast
.MoveNext
End If
'Add a new record
.AddNew
!ComputerName = strComputerName
Case wloRfUpdateExisting
'Move to the first record then find the current computer
If Not (.BOF And .EOF) Then
.MoveFirst
End If
.Find "ComputerName = '" & strComputerName & "'", , adSearchForward
'Add the record if find is unsuccessful
If .EOF Then
.AddNew
!ComputerName = strComputerName
End If
Case Else
'Do Nothing
End Select
'Now the cursor of rstConnectedUsers is on a New record OR on an existing record
'so now set the fields COMMON to an ADD or an UPDATE accordingly
!WorkGroupUser = strLoginName
!Connected = blIsConnected
!SuspectedState = strSuspectState
!Timestamp = dtTimestamp
.Update
End With 'rstConnectedUsers
'Move to the next MDB user record
rstUserRoster.MoveNext
Loop 'rstUserRoster
'Return the result ... if the code makes it to here, then no errors were generated
GetMDBLoggedUsers = True
'Clean Up
Clean_Up:
On Error Resume Next
If Not rstConnectedUsers Is Nothing Then
If rstConnectedUsers.State = adStateOpen Then rstConnectedUsers.Close
Set rstConnectedUsers = Nothing
End If
If Not rstUserRoster Is Nothing Then
If rstUserRoster.State = adStateOpen Then rstUserRoster.Close
Set rstUserRoster = Nothing
End If
Exit Function
Error_Handler:
'Display the errors if needed
If blViewErrors = True Then
MsgBox Err.Description & " (" & Err.Number & ")", vbExclamation
End If
'Clear the error and close the connection
Err.Clear
On Error Resume Next
If Not cnnDatafile Is Nothing Then
If cnnDatafile.State = adStateOpen Then cnnDatafile.Close
Set cnnDatafile = Nothing
End If
'Set the return value
GetMDBLoggedUsers = False
Resume Clean_Up
End Function
Public Function RemCode(strText, ParamArray intAsciiCodes()) As String
'Removes special characters from a string.
Dim X As Integer
Dim Y As Integer
Dim strX As String
Dim strStrippedText As String
Dim blCodeMatch As Boolean
'Start with the string
strText = Nz(Trim(strText))
'Loop through each digit of the string to determine if is an ASCII code to remove
For X = 1 To Len(strText)
strX = Mid(strText, X, 1)
'Look for a match in ascii codes to the passed parameters
blCodeMatch = False
For Y = 0 To UBound(intAsciiCodes())
If Asc(strX) = CInt(intAsciiCodes(Y)) Then
blCodeMatch = True
Exit For
End If
Next Y
'Add to the stripped text if there is not a match
If Not blCodeMatch Then
strStrippedText = strStrippedText & strX
End If
Next X
RemCode = strStrippedText
End Function