La siguiente función lee el archivo .ldb asociado a una base de datos de Access, y devulelve un listado con los usuarios que están conectados a la base de datos. El archivo .ldb se utiliza para determinar qué registros se bloquean en una base de datos compartida y quién los bloquea.
Public Function WhoIsInTheDatabaseLockFile() As String
Dim cn As New ADODB.Connection
Dim dbs As DAO.Database
Dim xlngLoop As Long
Dim rs As New ADODB.Recordset
Dim strNewDataSource As String, strCNString As String, xTT As String
Dim strCurrConnectString As String, xstrUserArray As String
Const strDummyTableName As String = "tbl__DummyTable_KeepRecordsetOpen"
Const strDatabaseString As String = "DATABASE="
Const strDataSourceText As String = "Data Source="
On Error GoTo Err_Msg
xstrUserArray = ""
strCurrConnectString = CurrentProject.Connection
strCNString = Mid(strCurrConnectString, InStr(strCurrConnectString, _
strDataSourceText) + Len(strDataSourceText))
strCNString = Left(strCNString, InStr(strCNString, ";") - 1)
Set dbs = CurrentDb
strNewDataSource = dbs.TableDefs(strDummyTableName).Connect
strNewDataSource = Mid(strNewDataSource, InStr(strNewDataSource, _
strDatabaseString) + Len(strDatabaseString))
Debug.Print "File containing the data tables: " & strNewDataSource
cn.ConnectionString = Replace(strCurrConnectString, strCNString, _
strNewDataSource, 1, 1, vbTextCompare)
cn.Open
Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name
While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), rs.Fields(2), rs.Fields(3)
For xlngLoop = 0 To 3
xTT = Trim(Nz(rs.Fields(xlngLoop), ""))
If Len(xTT) > 1 Then
If Right(xTT, 1) = Chr(0) Then xTT = Left(xTT, Len(xTT) - 1)
End If
xstrUserArray = xstrUserArray & xTT & strPipeDelimiterChar
Next xlngLoop
rs.MoveNext
Wend
If Len(xstrUserArray) > 0 Then xstrUserArray = Left(xstrUserArray, _
Len(xstrUserArray) - 1)
WhoIsInTheDatabaseLockFile = xstrUserArray
Exit_Function:
On Error Resume Next
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
dbs.Close
Set dbs = Nothing
Exit Function
Err_Msg:
Debug.Print "Error occurred. Error number " & Err.Number & ": " & Err.Description
Resume Exit_Function
End Function
Fuente: KDSnell