Informationen aus dem Active Directory ziehen mit ADO

Manchmal sehr brauchbar in Formularen und Excel Templates. Hier ist die VB6 Version.

Public Type ActiveDirectoryUserInfo
    adFirstName As String
    adLastName As String
    adDivision As String
    adDepartment As String
    adPhoneNumber As String
    adEmailAddress As String
    adLastLogin As Date
    adLastLogoff As Date
    adAccountExpiration As Date
    adPasswordExpiration As Date
End Type

'=================================================================
' Gets information of the user from the active directory
'=================================================================
Public Function GetUserInfoAD(UserID As String) As ActiveDirectoryUserInfo

    Dim oCon As New ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim oRoot As Object
    Dim oDomain As Object
    Dim sConCommand As String
    
    Dim retval As ActiveDirectoryUserInfo
    
    On Error GoTo ErrorTrap

    'Serverless binding see
    'http://msdn.microsoft.com/en-us/library/ms677945(VS.85).aspx
    Set oRoot = GetObject("LDAP://rootDSE")
    Set oDomain = GetObject("LDAP://" & oRoot.Get("defaultNamingContext"))
    'build the command string
    sConCommand = "<" & oDomain.ADsPath & ">;" & _
                    "(&(objectCategory=person)(objectClass=user)(name=" & UserID & "));" & _
                    "adsPath;subTree"
    'init the connection
    oCon.Provider = "ADsDSOObject"
    oCon.Open "Active Directory"
    'execute the query
    Set rs = oCon.Execute(sConCommand)
    'rs = eof if nothing is found
    If Not (rs.EOF) Then
    
        'get the info
        With GetObject(rs("adsPath"))
            'errors occures if the attribute is null
            'thats why we have to skip errors
            On Error Resume Next
            retval.adAccountExpiration = CDate(.AccountExpirationDate)
            retval.adDepartment = .Department
            retval.adDivision = .Division
            retval.adEmailAddress = .EmailAddress
            retval.adFirstName = .FirstName
            retval.adLastLogin = CDate(.LastLogin)
            retval.adLastLogoff = CDate(.LastLogoff)
            retval.adLastName = .LastName
            retval.adPasswordExpiration = CDate(.PasswordExpirationDate)
            retval.adPhoneNumber = .TelephoneNumber
        
        End With
    
    End If
    
ErrorTrap:
    'we have to kill everything first
    If Not (rs Is Nothing) Then
        If rs.STATE <> 0 Then rs.Close
        Set rs = Nothing
    End If
    If Not (oCon Is Nothing) Then
        If oCon.STATE <> 0 Then oCon.Close
        Set oCon = Nothing
    End If
    
    If Not (oRoot Is Nothing) Then Set oRoot = Nothing
    If Not (oDomain Is Nothing) Then Set oDomain = Nothing
    
    'return
    GetUserInfoAD = retval

End Function