VBA Tipp: Aktuelle Benutzer ermitteln

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

Ich möchte wissen, welche Benutzer zur Zeit auf meine Access-Datenbank zugreifen.

Lösung

Das geht per ADO so (ab Access 2000 bzw. Jet 4.0):

Public Sub BenutzerlisteAnzeigen(DBName As String)
 
 'DBName: Pfad und Name der zu untersuchenden Datenbank
 'Verweis auf Microsoft ActiveX Data Objects x.x Library notwendig
 'Quelle: www.dbwiki.net oder www.dbwiki.de
 
 Dim cn As New ADODB.Connection
 Dim rs As New ADODB.Recordset
 
 'OLE DB Provider je nach Access-Version zuweisen
 Select Case Application.SysCmd(acSysCmdAccessVer)
 
   'bis Access 2003
   Case Is <= "11.0"
     cn.Provider = "Microsoft.Jet.OLEDB.4.0"
 
   'ab Access 2007
   Case Else
     cn.Provider = "Microsoft.ACE.OLEDB.12.0"
 
 End Select
 
 cn.Open "Data Source = " & DBName
 
 Set rs = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
 
 ' Eine Liste der Benutzer für die angegebene Datenbank im Direktbereich ausgeben
 Debug.Print rs(0).Name, rs(1).Name, rs(2).Name, rs(3).Name
 Do Until rs.EOF
   Debug.Print Trim(rs(0)), Trim(rs(1)), Trim(rs(2)), Trim(rs(3))
   rs.MoveNext
 Loop
 
 rs.Close
 
End Sub

Aufruf

Im Direktfenster:

BenutzerlisteAnzeigen "D:\Eigene Dateien\MeineDatenbank.mdb"
COMPUTER_NAME      LOGIN_NAME      CONNECTED     SUSPECT_STATE
AURIGA             Admin           Wahr          Null
ANTARES            Meier           Wahr          Null

Alternative

Mit folgendem etwas längeren Modul können die zugreifenden Benutzer auch in A97 ff. herausgefunden werden. (Die Kernfunktion ist die API-Funktion LockFile(), mit der die von Jet verwalteten Sperren auf die .ldb-Datei ermittelt werden.) Aufruf der Prozedur TestUsers zeigt die Benutzer im Testfenster an.

Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const FILE_SHARE_READ = &H1
Public Const FILE_SHARE_WRITE = &H2
Public Const FILE_FLAG_RANDOM_ACCESS = &H10000000
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const OPEN_EXISTING = 3
Public Const FILE_BEGIN = 0
 
Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
 
Type SecInfo
    bMachine(1 To 32) As Byte
    bSecurity(1 To 32) As Byte
End Type
 
Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
Type BY_HANDLE_FILE_INFORMATION
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    dwVolumeSerialNumber As Long
    nFileSizeHigh As Long
    nFileSizeLow As Long
    nNumberOfLinks As Long
    nFileIndexHigh As Long
    nFileIndexLow As Long
End Type
 
Declare Function CreateFile Lib "kernel32" Alias _
        "CreateFileA" (ByVal lpFileName As String, _
        ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
        lpSecurityAttributes As SECURITY_ATTRIBUTES, _
        ByVal dwCreationDisposition As Long, _
        ByVal dwFlagsAndAttributes As Long, _
        ByVal hTemplateFile As Long) As Long
Declare Function CloseHandle Lib "kernel32" _
        (ByVal hObject As Long) As Long
Declare Function LockFile Lib "kernel32" (ByVal hFile As Long, _
        ByVal dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, _
        ByVal nNumberOfBytesToLockLow As Long, _
        ByVal nNumberOfBytesToLockHigh As Long) As Long
Declare Function UnlockFile Lib "kernel32" (ByVal hFile As Long, _
        ByVal dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, _
        ByVal nNumberOfBytesToUnlockLow As Long, _
        ByVal nNumberOfBytesToUnlockHigh As Long) As Long
Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, _
        ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, _
        ByVal dwMoveMethod As Long) As Long
Declare Function lread Lib "kernel32" Alias "_lread" _
        (ByVal hFile As Long, lpBuffer As Any, _
        ByVal wBytes As Long) As Long
 
 
Public Function TestUsers()
Dim strPath As String
Dim arrUserList As Variant
Dim n As Long
 
    strPath = CurrentDb.Name
    arrUserList = DBUsers(strPath)
    For n = 0 To UBound(arrUserList, 2)
        Debug.Print arrUserList(0, n), arrUserList(1, n)
    Next n
End Function
 
 
Public Function DBUsers(ByVal sDBPath As String) As Variant
Dim mSecurity As SECURITY_ATTRIBUTES
Dim fHandle As Long
Dim LDBInfo As SecInfo
Dim arrUser(254, 2) As String
Dim iCnt As Integer
Dim iOffset As Integer
Dim lBytesRead As Long
Dim dwPos As Long
Dim lLock As Long
Dim lByte As Long
Dim arrReturn() As String
Dim lngRet As Long
Dim nCount As Long
 
    On Error GoTo Fehler
    sDBPath = Mid(sDBPath, 1, InStr(1, sDBPath, ".") - 1) & ".ldb"
 
    With mSecurity
        .nLength = Len(mSecurity)
        .lpSecurityDescriptor = 0
        .bInheritHandle = True
    End With
 
    fHandle = CreateFile(sDBPath, _
                         GENERIC_READ Or GENERIC_WRITE, _
                         FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                         mSecurity, _
                         OPEN_EXISTING, _
                         FILE_FLAG_RANDOM_ACCESS Or FILE_ATTRIBUTE_NORMAL, 0)
 
    If fHandle = 0 Then Err.Raise _
       vbObjectError + 1, "ReadLocks", "LDB kann nicht geöffnet werden"
    SetFilePointer fHandle, 0, 0, FILE_BEGIN
    iOffset = 0
    iCnt = 0
 
    Do
        lBytesRead = lread(fHandle, LDBInfo, 64)
        If lBytesRead = 0 Then Exit Do
        If lBytesRead <> 64 Then Err.Raise _
           vbObjectError + 2, "ReadLocks", "Fehler beim Lesen der LDB"
        arrUser(iCnt, 0) = BytesToString(LDBInfo.bSecurity)
        arrUser(iCnt, 1) = BytesToString(LDBInfo.bMachine)
        arrUser(iCnt, 2) = iOffset
        iCnt = iCnt + 1
        iOffset = iOffset + 64
    Loop
 
    iCnt = 0
    dwPos = &H10000001
    ReDim arrReturn(1, 0)
    Do Until dwPos = &H100000FF
        lLock = LockFile(fHandle, dwPos, 0, 1, 0)
        If lLock = 0 Then
            lByte = HexToLong(Right$(Hex(dwPos), 2))
            iOffset = lByte * 64 - 64
            For iCnt = 0 To 254
                If arrUser(iCnt, 2) = "" Then Exit For
                If arrUser(iCnt, 2) = iOffset Then
                    ReDim Preserve arrReturn(1, nCount)
                    arrReturn(0, nCount) = arrUser(iCnt, 0)
                    arrReturn(1, nCount) = arrUser(iCnt, 1)
                    nCount = nCount + 1
                End If
            Next iCnt
        Else
            lLock = UnlockFile(fHandle, dwPos, 0, 1, 0)
        End If
        dwPos = dwPos + 1
    Loop
 
    CloseHandle (fHandle)
    DBUsers = arrReturn
Ende:
    Exit Function
 
Fehler:
    MsgBox Err.Description, vbCritical, Err.Source
    DBUsers = Null
    Resume Ende
End Function
 
Public Function BytesToString(arrBytes() As Byte) As String
Dim sTemp As String
 
    sTemp = StrConv(arrBytes(), vbUnicode)
    BytesToString = Left$(sTemp, (InStr(1, sTemp, Chr(0))) - 1)
End Function
 
Public Function HexToLong(ByVal sHex As String) As Long
    HexToLong = Val("&H " & sHex & "&")
End Function
Wiki hinweis.png

Hinweis: Die mancherorts verkündete Lösung, einfach den Inhalt der zu jeder geöffneten mdb-Datenbank existierenden .ldb-Datei auszulesen, um die Benutzer zu ermitteln, ist falsch (beim Öffnen der Datenbank db1.mdb entsteht automatisch eine db1.ldb).

Denn beim Schließen der Datenbank durch einen User wird sein Eintrag in dieser .ldb-Datei nicht entfernt, sondern bleibt solange bestehen, bis der letzte User die Datenbank geschlossen hat.


Weblinks