Db_Stuff said:
Is there a way of retrieving any open connections to an Access Database.
And
if so can the computer name from which these connections are established
from, also be retrieved or not?? Say for instance there are 3 computers
connected to a single access database located on a server, is there a way
to
retrieve the open connections to this database as well as the name of the
computers. Any help will be greatly appreciated..
There are a number of ways to do this, but using the OpenSchema method of an
ADO connection is my preference. Three things to bear in mind:
1) Normally databases are split back and front end. It is the shared
backend data which you normally want to know about. Therefore my example
assumes you have linked tables.
2) Someone could have the front end application open but not currently
using any bound form - so this user will not count as being logged in. If
this is an issue then make sure you keep some invisible bound form open so
users are always connected to the datasource if they are logged in.
3) If the database is secured with user level security, then different rules
apply.
I have structured this code to be used in conjunction with a linked table
and a listbox on a form. You could simply write the following on the form's
open event (and also a refresh button):
If Not GetUserList("tblDbInfo", Me.lstUsers) Then
Beep
End If
The nerdy code pasted into a module is like this:
Option Compare Database
Option Explicit
Private Enum QuoteTypeEnum
NoQuote
SingleQuote
DoubleQuote
End Enum
Private Const JET_SCHEMA_USERROSTER =
"{947bb102-5d43-11d1-bdbf-00c04fb92675}"
Private Declare Function apiGetComputerName Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'
Public Function GetUserList(strLinkTable As String, lstListBox As ListBox)
As Boolean
On Error GoTo Err_Handler
Dim strDbPath As String
Dim cnn As Object 'ADODB.Connection
Dim rst As Object 'ADODB.Recordset
Dim strValue As String
Dim strLine As String
Dim strReturn As String
Dim strConn As String
Dim strMyComputer As String
Dim bln As Boolean
On Error Resume Next
strDbPath = Mid$(CurrentDb.TableDefs(strLinkTable).Connect, 11)
On Error GoTo Err_Handler
If Len(strDbPath) = 0 Then
MsgBox "Path not specified", vbExclamation
Exit Function
End If
strMyComputer = GetComputerName()
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strDbPath
Set cnn = CreateObject("ADODB.Connection")
cnn.ConnectionString = strConn
cnn.Open
Set rst = cnn.OpenSchema(-1, , JET_SCHEMA_USERROSTER)
strReturn = AddQuotes("User", DoubleQuote) & ";" & _
AddQuotes("Machine", DoubleQuote) & ";" & _
AddQuotes("Connected", DoubleQuote) & ";" & _
AddQuotes("Suspect", DoubleQuote) & ";"
With lstListBox
.RowSourceType = "Value List"
.ColumnCount = 4
.ColumnHeads = True
End With
With rst
While Not .EOF
strLine = ""
' LOGIN_NAME:
strValue = CleanString(.Fields(1).Value)
strValue = StrConv(strValue, 3)
strValue = AddQuotes(strValue, DoubleQuote)
strLine = strLine & strValue & ";"
' COMPUTER_NAME:
strValue = CleanString(.Fields(0).Value)
If (strValue = strMyComputer) And (bln = False) Then
bln = True
strLine = "@@DeleteThisLine@@"
Else
strValue = AddQuotes(strValue, DoubleQuote)
strLine = strLine & strValue & ";"
End If
' CONNECTED:
strValue = CleanString(.Fields(2).Value)
strValue = AddQuotes(strValue, DoubleQuote)
strLine = strLine & strValue & ";"
' SUSPECT_STATE:
strValue = CleanString(.Fields(3).Value)
strValue = AddQuotes(strValue, DoubleQuote)
strLine = strLine & strValue & ";"
.MoveNext
If Left$(strLine, Len("@@DeleteThisLine@@")) <>
"@@DeleteThisLine@@" Then
strReturn = strReturn & strLine
End If
Wend
End With
lstListBox.RowSource = strReturn
GetUserList = True
Exit_Handler:
On Error Resume Next
If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
End If
If Not cnn Is Nothing Then
cnn.Close
Set cnn = Nothing
End If
Exit Function
Err_Handler:
MsgBox Err.Description, vbExclamation, "Error No: " & Err.Number
Resume Exit_Handler
End Function
Private Function CleanString(varValue As Variant) As String
Dim strReturn As String
Dim lngPos As Long
strReturn = Nz(varValue, "")
lngPos = InStr(strReturn, vbNullChar)
If lngPos > 0 Then
strReturn = Left$(strReturn, lngPos - 1)
End If
strReturn = Trim$(strReturn)
CleanString = strReturn
End Function
Private Function AddQuotes(strValue, Q As QuoteTypeEnum) As String
Dim strReturn As String
Select Case Q
Case QuoteTypeEnum.SingleQuote
strReturn = Replace(strValue, "'", "''")
strReturn = "'" & strReturn & "'"
Case QuoteTypeEnum.DoubleQuote
strReturn = Replace(strValue, """", """""")
strReturn = """" & strReturn & """"
Case Else
strReturn = strValue
End Select
AddQuotes = strReturn
End Function
Private Function GetComputerName() As String
Dim strName As String
strName = String$(16, 0)
If apiGetComputerName(strName, 16) <> 0 Then
GetComputerName = CleanString(strName)
End If
End Function
