Excel Add-on for querying Active Directory

Below are some utility VBA functions that query user information from active directory. These can be added to an .xla file, and loaded as an Excel add-on. This will provide excel functions like ADUserProperty, managerOf, emailOf etc. The only down side is that each function call is a blocking network operation, so flash-filling them for large number of rows might cause excel to freeze for some time.
Option Explicit

Public Function getADDomain() As String
    Dim objLdap As Object
    Dim strLdapDomain As String

    On Error Resume Next
    Set objLdap = GetObject("LDAP://rootDSE")
    On Error GoTo 0

    If (objLdap Is Nothing) Then
        Exit Function
    End If

    strLdapDomain = objLdap.Get("defaultNamingContext")

    If (Trim(strLdapDomain) = "") Then
        Exit Function
    Else
    getADDomain = strLdapDomain
    End If
End Function


Public Function ADUserProperty(ByVal strUserId As String, ByVal adField As String, Optional ByVal domainStr As String = "DEFAULT_DOMAIN") As String

    Dim objLdapConnection As Object
    Dim objLdapCommand As Object
    Dim objLdapRecordSet As Object

    Dim objField As Variant

    ' Connect to ActiveDirectory using ADODB
    Set objLdapConnection = CreateObject("ADODB.Connection")
    Call objLdapConnection.Open("Provider=ADsDSOObject;")

    ' Create command to queryActiveDirectory using LDAP
    Set objLdapCommand = CreateObject("ADODB.Command")

    ' Set the query properties
    With objLdapCommand
        ' Set the connection
        .ActiveConnection = objLdapConnection

        ' Search the AD recursively, starting at the root of the domain
        .CommandText = "<LDAP://" & Trim(domainStr) & ">;" & _
          "(&(objectCategory=User)" & _
          "(|(sAMAccountName=" & Trim(strUserId) & ")" & _
          "(distinguishedName=" & Trim(strUserId) & ")" & _
          "(displayName=" & Trim(strUserId) & ")" & _
          "(cn=" & Trim(strUserId) & ")" & _
          "(mail=" & Trim(strUserId) & ")));" & _
          Trim(adField) & ";subtree"
    End With

    ' Execute LDAP query
    Set objLdapRecordSet = objLdapCommand.Execute

    If (objLdapRecordSet.BOF Or objLdapRecordSet.EOF) Then
        ADUserProperty = "0"
        Exit Function
    Else
        ' Walk through all users
        Do While (Not objLdapRecordSet.EOF)

            objField = objLdapRecordSet.Fields(Trim(adField))

            If (Trim(adField) = "description") Then
             ADUserProperty = Join(VariantArrayToStringArray(objField))
            ElseIf (objField <> vbNull) Then
               ADUserProperty = objField
            End If
             ' Next record
             Call objLdapRecordSet.MoveNext
         Loop

         If (Not objLdapRecordSet Is Nothing) Then
            Call objLdapRecordSet.Close
            Set objLdapRecordSet = Nothing
         End If
    End If
    Set objLdapCommand = Nothing
End Function

Public Function managerOf(ByVal strUserId As String, Optional ByVal domainStr As String = "DEFAULT_DOMAIN") As String
    Dim managerDN As String

    managerDN = ADUserProperty(strUserId, "manager", domainStr)
    If (managerDN = "0") Then
        managerOf = "0"
    Else
        managerOf = ADUserProperty(managerDN, "cn", domainStr)
    End If
End Function

Public Function managerEmailOf(ByVal strUserId As String, Optional ByVal domainStr As String = "DEFAULT_DOMAIN") As String
    Dim managerDN As String

    managerDN = ADUserProperty(strUserId, "manager", domainStr)
    If (managerDN = "0") Then
        managerEmailOf = "0"
    Else
        managerEmailOf = ADUserProperty(managerDN, "mail", domainStr)
    End If
End Function

Public Function emailOf(ByVal strUserId As String, Optional ByVal domainStr As String = "DEFAULT_DOMAIN") As String
        emailOf = ADUserProperty(strUserId, "mail", domainStr)
End Function

Public Function descriptionOf(ByVal strUserId As String, Optional ByVal domainStr As String = "DEFAULT_DOMAIN") As String
        descriptionOf = ADUserProperty(strUserId, "description", domainStr)
End Function


' Array Variant to String
Public Function VariantArrayToStringArray(ByVal arrVariants As Variant) As String()
    Dim arrStrings() As String
    ' Get the string array
    Call ParamArrayToStringArray(arrVariants, arrStrings)
    ' Get the string array
    VariantArrayToStringArray = arrStrings
End Function

' Array Variant to String
Public Sub ParamArrayToStringArray(ByVal arrVariants As Variant, ByRef arrStrings() As String)
    Dim intLength As Integer
    ' Handle the array
    Call ParamArrayToStringArrayInternal(arrVariants, arrStrings, intLength)
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


' Array Variant to String
Private Sub ParamArrayToStringArrayInternal(ByVal arrVariants As Variant, ByRef arrStrings() As String, ByRef intLength As Integer)
    ' Parameter is array?
    If (IsArray(arrVariants)) Then
        Dim i As Integer
        Dim objValue As Variant
        ' Walk through the specified partner objects
        For i = LBound(arrVariants) To UBound(arrVariants) Step 1
            ' Get the value
            objValue = arrVariants(i)
            ' Array to string
            Call ParamArrayToStringArrayInternal(objValue, arrStrings, intLength)
        Next
    Else
        ' Next item
        intLength = intLength + 1
        ' Expand array
        ReDim Preserve arrStrings(1 To intLength)

        ' Set the value
        arrStrings(intLength) = CStr(arrVariants)
    End If
End Sub

' String Array
' Convert ParamArray to String array
Public Function StringArray(ParamArray arrValues() As Variant) As String()
    ' Get the string array
    StringArray = VariantArrayToStringArray(arrValues)
End Function