Kodeeks - ListUsers

Denne funktion kan fortælle dig hvilke og hvormange brugere, som har en given database åben (Angiv en sti til databasen eller benyt den aktuelle database).

Public Function ListUsers(Optional DatabaseSti As String) As Byte
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim intUser As Integer
    Dim fld As ADODB.Field
    Dim Brugernavne As String
      
    ' Brugerliste-schema informationerne kræver denne magiske kode.
    ' Hvorfor der ikke er foruddefineret en konstant til dette, er et mysterium
    Const adhcUsers = "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
   
    Set cnn = New ADODB.Connection
    If DatabaseSti = "" Then
        Set cnn = CurrentProject.Connection
    Else
        cnn.Provider = "Microsoft.Jet.OLEDB.4.0;Data Source=" & DatabaseSti & ";User ID=Admin;Password=;"
        cnn.Open
    End If
   
    Set rst = cnn.OpenSchema(adSchemaProviderSpecific, , adhcUsers)
   
    With rst
        Do Until .EOF
            intUser = intUser + 1
            Brugernavne = Brugernavne & "Bruger # " & intUser & vbNewLine
            For Each fld In .Fields
                If fld.Name = "COMPUTER_NAME" Or fld.Name = "LOGIN_NAME" Then
                    Brugernavne = Brugernavne & "   " & fld.Name & "=" & Trim(Replace(fld.Value, Chr(0), "")) & vbNewLine
                End If
            Next
            .MoveNext
        Loop
    End With
    ListUsers= intUser
    rst.Close
    Set rst = Nothing
    cnn.Close
    Set cnn = Nothing
    If intUser = 1 Then
        MsgBox "Der er ingen andre brugere på denne database!", vbExclamation, "Ingen brugere!"
    Else
        MsgBox Brugernavne, vbInformation, "Følgende " & intUser & " bruger(e) har databasen åben:"
    End If
End Function

Vejledning:
Indsæt funktionen i et modul. Luk databasen og åbn den igen.
Ønsker du at få listet brugere, som er logget på den aktuelle database, kaldes blot
ListUsers

Ønsker du at få listet brugere på en ekstern database, kaldes funktionen således:
ListUsers "X:\Databaser\XDatabase.mdb"
eller
Antal = ListUsers("X:\Databaser\XDatabase.mdb" )

Hvis man benytter sig af muligheden for at få returneret antallet, kan det være en ide at fjerne de 5 sidste linier i funktionen (dem med MsgBox).