Blog Code Listings for Videos

Microsoft Access An Admin Db Part 3 – Prevent Logins – Access Jitsu

Choice Examine Database

Choice Specific

Public dbForUserDetail As Long

Dim connArray(25) As New ADODB.Connection

‘********************************************************************

‘*                 F O R M         E V E N T S

‘********************************************************************

Personal Sub Form_Load()

Name LoadJetUsers

Call ShowDbUserList

Finish Sub

Personal Sub Form_Timer()

Name LoadJetUsers

Name ShowDbUserList

Finish Sub

‘Filter out all Db locks, since all locked Db’s can be released

Personal Sub Form_Close()

On Error GoTo SubError

Dim SQL As String

Dim i As Integer

SQL = “UPDATE MonitoredDatabases SET Status = ””

CurrentDb.Execute SQL, dbFailOnError

For i = LBound(connArray) To UBound(connArray)

If connArray(i).Supplier <> “MSDASQL” _

And connArray(i).Provider <> “” Then

connArray(i).Shut

Set connArray(i) = Nothing

Finish If

Next i

SubExit:

On Error Resume Next

Exit Sub

SubError:

MsgBox Me.Identify & “/Form_Close – Error – ” & Err.Quantity & “: ” & Err.Description

GoTo SubExit

End Sub

‘********************************************************************

‘*                 U S E R         E V E N T S

‘********************************************************************

Personal Sub cmdLock_Click()

Call SetDbStatus(“Lock”)

Finish Sub

Personal Sub cmdUnLock_Click()

Call SetDbStatus(“UnLock”)

Finish Sub

‘********************************************************************

‘*              M E T H O D S    &    F U N C T I O N S

‘********************************************************************

Public Sub ShowDbUserList()

Call Form_subformUserList.LoadUserDetail(dbForUserDetail)

End Sub

Public Sub LoadJetUsers()

On Error GoTo SubError

Dim rs As ADODB.Recordset

Dim SQL As String

Dim rs2 As DAO.Recordset

Dim MachineName As String

Dim i As Integer

Dim ADOerrs As ADODB.Errors

Dim ADOerror As ADODB.Error

Dim errString As String

txtStatus = “Requerying databases…”

DoEvents

MachineName = GetMachineName

‘Filter out LoggedIn table

SQL = “DELETE * FROM UsersLoggedIn”

CurrentDb.Execute SQL, dbFailOnError

‘populate a dao recordset with databases to we need to monitor

SQL = “SELECT DbID, DbDisplayName, DbPath, Status FROM MonitoredDatabases WHERE Active = True”

Set rs2 = CurrentDb.OpenRecordset(SQL, dbOpenDynaset)

‘Loop by way of the databases

Do While Not rs2.EOF

‘want a Db path – verify knowledge

If IsNull(rs2!DbPath) _

Or Trim(rs2!DbPath) = “” Then

GoTo NextDb

End If

On Error GoTo ADOerror

‘Is the Db we need to examine already in our connection array?

i = FindConnInArray(rs2!DbPath)

If i = -1 Then      ‘no room left within the connection array

GoTo NextDb

Finish If

‘At this level, i holds the component we need to use in our conn array

‘ The consumer roster is uncovered as a provider-specific

‘ schema rowset within the Jet 4 OLE DB provider.  You need to use

‘ a GUID to reference the schema, as provider-specific schemas

‘ aren’t listed in ADO’s sort library for schema rowsets

‘Fields in this recordset:

‘1.  COMPUTER_NAME

‘2.  LOGIN_NAME

‘3.  Related

‘4.  SUSPECT_STATE

‘Question the db to see who has it open and insert them ‘Question the db to see who has it open and insert them

Set rs = connArray(i).OpenSchema(adSchemaProviderSpecific, , _

“947bb102-5d43-11d1-bdbf-00c04fb92675”)

‘1.  Add code to exclude the monitoring pc from our consumer record

‘2.  If you wish to refresh the display fairly often, you’ll be able to log once you

‘    see a new login to get a begin time

‘3.  You can also report these logins in an audit table to keep a report

‘    of who logged in and when

Do Whereas Not rs.EOF

If MachineName <> Exchange(Trim(rs.Fields(0)), Chr(0), “”) Then

SQL = “INSERT INTO UsersLoggedIn “

SQL = SQL & “(DbID, DatabaseName, ComputerName, LoginName, Related, SuspectState) “

SQL = SQL & “VALUES (” & rs2!dbID & “, ‘” & rs2!DbDisplayName & “‘, ‘”

SQL = SQL & Exchange(Trim(rs.Fields(zero)), Chr(zero), “”) & “‘, ‘”

SQL = SQL & Substitute(Trim(rs.Fields(1)), Chr(zero), “”) & “‘, ‘”

SQL = SQL & rs.Fields(2) & “‘, ‘” & Nz(rs.Fields(3), “”) & “‘)”

CurrentDb.Execute SQL, dbFailOnError

Finish If

‘Get Subsequent Consumer

rs.MoveNext

Loop        ‘finish of users logged-in loop

‘shut this recordset

rs.Shut

”conn.Shut

On Error GoTo SubError

NextDb:

‘Get subsequent database

rs2.MoveNext

Loop        ‘finish of monitored databases loop

rs2.Close

Form_subformDbList.Requery

‘Examine to see which db was chosen earlier than we refreshed and choose it again

If dbForUserDetail = 0 Then

Form_subformDbList.Recordset.MoveFirst

dbForUserDetail = Form_subformDbList.txtDbID

Name ShowDbUserList

Else

Form_subformDbList.Recordset.FindFirst “DbID = ” & dbForUserDetail

Call ShowDbUserList

End If

txtStatus = “”

DoEvents

SubExit:

On Error Resume Subsequent

Set rs = Nothing

Set rs2 = Nothing

Exit Sub

SubError:

MsgBox Me.Identify & “/LoadJetUsers – Error – ” & Err.Quantity & “: ” & Err.Description

GoTo SubExit

ADOerror: On Error Resume Subsequent

errString = “”

Set ADOerrs = connArray(i).Errors

For Each ADOerror In ADOerrs

errString = errString & ADOerror.Quantity & “: ” & ADOerror.Description & vbCrLf

If ADOerror.Number = -2147467259 Then

‘in case we’ve got found a db locked by someone else, update the desk to mirror

rs2.Edit

rs2!Status = “Locked”

rs2.Update

GoTo NextDb

End If

Subsequent

If errString = “” Then

errString = Err.Number & “: ” & Err.Description

Finish If

MsgBox Me.Identify & “/LoadJetUsers – Error – ” & connArray(i).Errors(0).Number & “: ” & connArray(i).Errors(zero).Description

GoTo SubExit

End Sub

‘Returns -1 if connection object not found or can’t be created

‘otherwise, returns aspect index if discovered

‘OR index of latest aspect of an newly opened connection

Personal Perform FindConnInArray(strPath As String) As Integer

Dim i As Integer

Dim rtn As Integer

rtn = -1

For i = LBound(connArray) To UBound(connArray)

If InStr(connArray(i).ConnectionString, strPath) <> 0 Then

rtn = i

i = UBound(connArray)       ‘early exit

Finish If

Subsequent i

If rtn = -1 Then      ‘not in array but, load it and open connection

i = FindOpenConnArraySpot

If i = -1 Then      ‘no room left in the connection array

GoTo SubExit

End If

rtn = i

‘connArray(i).Supplier = “Microsoft.Jet.OLEDB.4.0”   ‘pre-2007 variations

connArray(i).Supplier = “Microsoft.ACE.OLEDB.12.0”

connArray(i).Open strPath

Finish If

SubExit:

FindConnInArray = rtn

End Perform

‘Returns an integer of the primary open spot it finds

‘within the connection array

‘Returns -1 if there are not any empty spots

Personal Perform FindOpenConnArraySpot() As Integer

Dim rtn As Integer

Dim i As Integer

rtn = -1

For i = LBound(connArray) To UBound(connArray)

If connArray(i).Provider = “MSDASQL” _

Or connArray(i).Provider = “” Then      ‘this factor is empty, use it!

rtn = i

i = UBound(connArray)

Finish If

Next i

FindOpenConnArraySpot = rtn

Finish Perform

Personal Sub SetDbStatus(Status As String)

On Error GoTo SubError

Dim SQL As String

Dim rs As DAO.Recordset

Dim path As String

Dim i As Integer

Dim cnFound As Boolean

SQL = “SELECT DbPath, Status FROM MonitoredDatabases WHERE DbID = “

SQL = SQL & dbForUserDetail & ” “

Set rs = CurrentDb.OpenRecordset(SQL, dbOpenDynaset)

If rs.RecordCount <> zero Then

‘Is the Db we need to work on already in our connection array?

i = FindConnInArray(rs!DbPath)

If i = -1 Then      ‘not in array yet, load it and open connection

i = FindOpenConnArraySpot

If i = -1 Then      ‘no room left within the connection array

GoTo SubExit    ‘maybe warn consumer

End If

‘connArray(i).Provider = “Microsoft.Jet.OLEDB.4.0”   ‘pre-2007 variations

connArray(i).Supplier = “Microsoft.ACE.OLEDB.12.0”

connArray(i).Open rs!DbPath

End If

rs.Edit     ‘put rs in edit mode

If Standing = “Lock” Then

connArray(i).Properties(“Jet OLEDB:Connection Control”) = 1

rs!Standing = “Locked”

Else

connArray(i).Properties(“Jet OLEDB:Connection Control”) = 2

rs!Status = “”

Finish If

rs.Replace       ‘push change in rs to desk

End If

rs.Shut

Form_subformDbList.Requery

Form_subformDbList.Recordset.FindFirst “DbID = ” & Form_frmAdmin.dbForUserDetail

SubExit:

On Error Resume Subsequent

Set rs = Nothing

Exit Sub

SubError:

MsgBox Me.Identify & “/SetDbStatus – Error – ” & Err.Number & “: ” & Err.Description

GoTo SubExit

Finish Sub