Option Compare Database
Option Explicit

Sub Dummy()
    '
    ' Der aktuelle Datenbankuser
    '
    MsgBox Application.CurrentUser
    '
    ' Der aktuelle Windows-User
    '
    MsgBox Environ("Username")
    
    MsgBox GetUserGroups("Admin")
    MsgBox GetGroupUsers("Admins")
    
End Sub

Function GetUserGroups(sUserName As String) As String
'
' GetUserGroups()
'
' Ermittlung der Benutzergruppen, denen ein Benutzer
' angehört.
'
' IN:   sUserName   Name des Benutzers, für den die
'                   Gruppen ermittelt werden sollen
'
' OUT:  String, in dem alle Benutzergruppen (durch
'       Semikolon getrennt aufgeführt sind.
'
Dim g As Group      ' Gruppe aus dem Workspace
Dim a As User       ' Eine Benutzerdefinition
Dim i As Integer    ' Zähler
Dim j As Integer    ' noch ein Zähler
Dim sRet As String  ' Return-String
    '
    ' Defaultvalue ist eine leere Gruppenliste
    '
    sRet = ""
    '
    ' Parameter prüfen
    '
    If Trim(sUserName) = "" Then GoTo GetUserGroups_Exit:
    '
    ' Schleife über alle Benutzer der Datenbank.
    '
    For i = 0 To DBEngine.Workspaces(0).Users.Count - 1
        '
        ' nächsten Benutzer holen
        '
        Set a = DBEngine.Workspaces(0).Users(i)
        '
        ' ist der gesuchte Benutzer gefunden ?
        '
        If UCase(a.Name) = UCase(sUserName) Then
            '
            ' Schleife über alle Gruppen des Benutzers
            '
            For j = 0 To a.Groups.Count - 1
                '
                ' nächste Grupee holen
                '
                Set g = a.Groups(j)
                '
                ' Namen der Gruppe in die Liste aufnehmen
                '
                sRet = sRet & g.Name & ";"
            Next j
            GoTo GetUserGroups_ListeKomplett
        End If
    
    Next i
    
GetUserGroups_ListeKomplett:
    If sRet <> "" Then
        '
        ' Für den Fall, daß mind. eine Gruppe gefunden
        ' wurde, muß das letzte Semikiolon aus der Liste
        ' entfernt werden.
        '
        sRet = Left(sRet, Len(sRet) - 1)
    End If
    '
    ' Speicherbereicht freigeben
    '
    Set g = Nothing
    Set a = Nothing
    '
    ' Nicht vergessen, die Liste zurückzugeben.
    '
GetUserGroups_Exit:

    GetUserGroups = sRet
End Function

Function GetGroupUsers(sGroupName As String) As String
'
' GetGroupUsers()
'
' Ermittlung aller Benutzer, die einer
' bestimmten Benutzergruppe angehöen.
'
' IN:   sGroupName  Name der Gruppe, für den die
'                   Benutzer ermittelt werden sollen
'
' OUT:  String, in dem alle Benutzer der Gruppe (durch
'       Semikolon getrennt aufgeführt sind.
'
Dim g As Group      ' Gruppe aus dem Workspace
Dim a As User       ' Eine Benutzerdefinition
Dim i As Integer    ' Zähler
Dim j As Integer    ' noch ein Zähler
Dim sRet As String  ' Return-String
    '
    ' Defaultvalue ist eine leere Gruppenliste
    '
    sRet = ""
    '
    ' Parameter prüfen
    '
    If Trim(sGroupName) = "" Then GoTo GetGroupUsers_Exit:
    '
    ' Schleife über alle Benutzergruppen des Workspaces.
    '
    For i = 0 To DBEngine.Workspaces(0).Groups.Count - 1
        '
        ' nächsten Benutzergruppe holen
        '
        Set g = DBEngine.Workspaces(0).Groups(i)
        '
        ' ist die gesuchte Benutzergruppe gefunden ?
        '
        If UCase(g.Name) = UCase(sGroupName) Then
            '
            ' Schleife über alle Benutzer der Gruppe
            '
            For j = 0 To g.Users.Count - 1
                '
                ' nächsten Benutzer holen
                '
                Set a = g.Users(j)
                '
                ' Namen der Gruppe in die Liste aufnehmen
                '
                sRet = sRet & a.Name & ";"
            Next j
            GoTo GetGroupUsers_ListeKomplett
        End If
    
    Next i
    
GetGroupUsers_ListeKomplett:
    If sRet <> "" Then
        '
        ' Für den Fall, daß mind. eine Gruppe gefunden
        ' wurde, muß das letzte Semikiolon aus der Liste
        ' entfernt werden.
        '
        sRet = Left(sRet, Len(sRet) - 1)
    End If
    '
    ' Speicherbereicht freigeben
    '
    Set g = Nothing
    Set a = Nothing
    '
    ' Nicht vergessen, die Liste zurückzugeben.
    '
GetGroupUsers_Exit:

    GetGroupUsers = sRet
End Function