Blog Code Listings for Videos

Microsoft Access An Admin Db Part 5 – Force Users of Other Databases to Logout – Access Jitsu

Choice Examine Database

Choice Specific

Public dbForUserDetail As Lengthy

Dim connArray(25) As New ADODB.Connection

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

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

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

Personal Sub Form_Load()

Call LoadUsers

Name ShowDbUserList

End Sub

Personal Sub Form_Timer()

Name LoadUsers

Name ShowDbUserList

End Sub

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

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

On Error Resume Next

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

If connArray(i).Supplier “MSDASQL” _

And connArray(i).Provider “” Then

connArray(i).Shut

Set connArray(i) = Nothing

End If

Subsequent i

SubExit:

On Error Resume Subsequent

Exit Sub

SubError:

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

GoTo SubExit

Finish Sub

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

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

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

Personal Sub cmdLock_Click()

Call SetDbStatus(“Lock”)

End Sub

Personal Sub cmdUnLock_Click()

Call SetDbStatus(“UnLock”)

Name ForceLogout(False)

End Sub

Personal Sub cmdLogout_Click()

Name ForceLogout(True)

End Sub

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

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

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

Public Sub ShowDbUserList()

Name Form_subformUserList.LoadUserDetail(dbForUserDetail)

Finish Sub

Public Sub LoadUsers()

On Error GoTo SubError

Dim rs As New 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 desk

SQL = “DELETE * FROM UsersLoggedIn”

CurrentDb.Execute SQL, dbFailOnError

‘populate a dao recordset with databases we would like to monitor

SQL = “SELECT DbID, DbDisplayName, DbPath, Standing, UserListQuery “

SQL = SQL & “FROM MonitoredDatabases “

SQL = SQL & “WHERE Lively = True “

Set rs2 = CurrentDb.OpenRecordset(SQL, dbOpenDynaset)

‘Loop by means of the databases

Do While Not rs2.EOF

‘need a Db path – examine knowledge

If IsNull(rs2!DbPath) _

Or Trim(rs2!DbPath) = “” Then

GoTo NextDb

Finish If

On Error GoTo ADOerror

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

i = FindConnInArray(rs2!DbPath)

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

GoTo NextDb

End If

‘At this level, i holds the aspect we would like to use in our conn array

‘Query the db to see who has it open and insert them into our users desk

rs.Open “SELECT * FROM ” & rs2!UserListQuery, connArray(i)

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

‘2.  If you would like to refresh the display very often, you possibly can log if you

‘    see a brand new login to get a start time

‘three.  You may additionally document these logins in an audit table to maintain a report

‘    of who logged in and when

Do Whereas Not rs.EOF

‘If MachineName Nz(rs!ComputerName, “”) Then

SQL = “INSERT INTO UsersLoggedIn “

SQL = SQL & “(DbID, DatabaseName, ComputerName, LoginName, LoginDateTime) “

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

SQL = SQL & Nz(rs!ComputerName, “”) & “‘, ‘”

SQL = SQL & Nz(rs!LoginName, “”) & “‘, #”

SQL = SQL & Nz(rs!LoginDateTime, Now) & “#)”

CurrentDb.Execute SQL, dbFailOnError

‘Finish If

‘Get Subsequent Consumer

rs.MoveNext

Loop        ‘finish of users logged-in loop

‘close this recordset

rs.Shut

On Error GoTo SubError

NextDb:

‘Get subsequent database

rs2.MoveNext

Loop        ‘finish of monitored databases loop

rs2.Shut

Form_subformDbList.Requery

‘Verify to see which db was selected earlier than we refreshed and select it once more

If dbForUserDetail = zero Then

Form_subformDbList.Recordset.MoveFirst

Call ShowDbUserList

Else

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

End If

txtStatus = “”

DoEvents

SubExit:

On Error Resume Subsequent

Set rs = Nothing

Set rs2 = Nothing

Exit Sub

SubError:

MsgBox Me.Identify & “/LoadUsers – Error – ” & Err.Number & “: ” & 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.Quantity = -2147467259 Then

‘in case we’ve discovered a db locked by someone else, replace the table to mirror

rs2.Edit

rs2!Standing = “Locked”

rs2.Replace

GoTo NextDb

End If

Next

If errString = “” Then

errString = “Check if ” & rs2!UserListQuery & ” exists in monitored database.” & vbCrLf

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

End If

MsgBox Me.Identify & “/LoadUsers – Error – ” & errString

GoTo SubExit

Finish Sub

‘Returns -1 if connection object not discovered

‘otherwise, returns aspect index if found

‘or index of new component

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

Next i

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

rtn = FindOpenConnArraySpot

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

GoTo SubExit

End If

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

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

connArray(rtn).Open strPath

End 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).Supplier = “” Then      ‘this component is empty, use it!

rtn = i

i = UBound(connArray)

End If

Subsequent i

FindOpenConnArraySpot = rtn

End Perform

‘Expects 2 strings:  “Lock”, “UnLock”

Personal Sub SetDbStatus(Standing 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, Standing FROM MonitoredDatabases WHERE DbID = “

SQL = SQL & dbForUserDetail & ” “

Set rs = CurrentDb.OpenRecordset(SQL, dbOpenDynaset)

If rs.RecordCount zero Then

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

i = FindConnInArray(rs!DbPath)

rs.Edit     ‘put rs in edit mode

If Status = “Lock” Then

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

rs!Status = “Locked”

Else

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

rs!Status = “”

End If

rs.Replace       ‘push change in rs to table

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

‘True = pressure users out

Personal Sub ForceLogout(ForceOut)

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

Dim cmd As New ADODB.Command

Dim param As ADODB.Parameter

SQL = “SELECT DbPath, Standing, ForceLogoutQuery, LoggingOut FROM MonitoredDatabases WHERE DbID = “

SQL = SQL & dbForUserDetail & ” “

Set rs = CurrentDb.OpenRecordset(SQL, dbOpenDynaset)

If rs.RecordCount zero Then

‘If we’re going pressure users to logout, let’s forestall others from logging in

If ForceOut = True Then

If rs!Status “Locked” Then

Call SetDbStatus(“Lock”)

Finish If

End If

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

i = FindConnInArray(rs!DbPath)

If i = -1 Then  ‘-1 means didn’t find db

‘warn consumer there’s a drawback

MsgBox “Cannot find the connection object of the selected database”, vbCritical + vbOKOnly, “Error”

GoTo SubExit

End If

‘Establish connection to Db and execute query to set Logout value

If Nz(rs!ForceLogoutQuery, “”) “” Then

cmd.ActiveConnection = connArray(i)

cmd.CommandType = adCmdStoredProc

cmd.CommandText = rs!ForceLogoutQuery

Set param = cmd.CreateParameter(, adBoolean, adParamInput)

param.Worth = ForceOut

cmd.Parameters.Append param

cmd.Execute

Else

‘ warn users we’ve a problem with the monitored db table

MsgBox “Cannot find ‘ForceLogout’ query of the selected database”, vbCritical + vbOKOnly, “Error”

GoTo SubExit

End If

‘Update the show so show we are forcing users out

rs.Edit

If ForceOut = True Then

rs!LoggingOut = “Yes”

Else

rs!LoggingOut = “”

End If

rs.Replace

Form_subformDbList.Requery

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

Finish If

rs.Close

SubExit:

On Error Resume Subsequent

Set rs = Nothing

Exit Sub

SubError:

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

GoTo SubExit

Finish Sub