使用ADO读取LDAP描述

我正在尝试下面的LDAP查询。“描述”字段通常为空,但如果存在数据,则在RS.Fields(vFields(iCol))上会出现类型不匹配错误。描述列的值。ADO数据类型报告为12-Variant。我试图将该值分配给VBA变量,但没有成功。

请原谅写入文件时出现多余的行。如果尝试复制,需要参考Microsoft ADO 6。同时更改为OU

如何在VBA中使用ADP数据类型12?我可以修改SELECT语句以将Description转换为其他数据类型吗?

        Option Explicit

        Sub GatherAttrs()
        On Error GoTo Local_error
            Dim objShell
            Dim objFSO
            Dim strOutputFileName, objOutputFileName, s, s2
            Dim RS As ADODB.Recordset
            Dim objConnection As ADODB.Connection
            Dim objCommand As ADODB.Command
            Const ForReading = 1, ForWriting = 2, ForAppending = 8
            Dim i As Integer
            Dim iRow As Integer
            Dim iCol As Integer
            Dim wks As Worksheet
            Dim sFields As String
            Dim vFields() As String
            Dim v As Variant

            Set wks = Worksheets.Add()

        '    Set objShell = WScript.CreateObject("WScript.Shell")
        '    Set objFSO = CreateObject("Scripting.FileSystemObject")
        '    strOutputFileName = InputBox("Out filename:", , "UserList2.txt")
        '    Set objOutputFileName = objFSO.OpenTextFile(strOutputFileName, ForWriting, True)
            Const ADS_SCOPE_SUBTREE = 2

            Set objConnection = CreateObject("ADODB.Connection")
            Set objCommand = CreateObject("ADODB.Command")
            objConnection.Provider = "ADsDSOObject"
            objConnection.Open "Active Directory Provider"
            Set objCommand.ActiveConnection = objConnection


            ' ** ** top 1000
            objCommand.Properties("Page Size") = 1000
            objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE


            sFields = "givenName,initials,sn,displayName,userPrincipalName,sAMAccountName,description,physicalDeliveryOfficeName,telephoneNumber,mail,pager,mobile,facsimileTelephoneNumber,employeeID,employeeNumber,departmentNumber,title,department,company,manager"
            vFields = Split(sFields, ",")

            s = "SELECT "
            s = s & sFields
            ' ** ** modify OU for your scope ** **
            s = s & " FROM 'LDAP://ou=APCD,dc=wings,dc=co,dc=slo,dc=ca,dc=us' "
            s = s & " WHERE objectCategory='user' order by Name"
            objCommand.CommandText = s

            Set RS = objCommand.Execute

            If RS.EOF Then
                MsgBox "ADS search failed - check OU" & vbNewLine & objCommand.CommandText
                GoTo Local_Exit
            End If
            iRow = 1
            For iCol = 1 To UBound(vFields)
                wks.Cells(iRow, iCol) = vFields(iCol)
            Next iCol

            RS.MoveFirst
            Do Until RS.EOF
                iRow = iRow + 1
                For iCol = 1 To UBound(vFields)
                    v = RS.Fields(vFields(iCol)).Value
                    wks.Cells(iRow, iCol) = RS.Fields(vFields(iCol)).Value & ""
                Next iCol
                RS.MoveNext
            Loop
        '    objOutputFileName.Writeline (s)
        '    objOutputFileName.Close
            'Wscript.Echo s
            wks.Activate
        Local_Exit:
            Exit Sub
        Local_error:
            MsgBox Err & " " & Err.Description
            If Err.Number = 13 Then Resume Next
            Resume Local_Exit
            Resume
            Resume Next
        End Sub

建议答案后的最终代码。

RS.MoveFirst
Do Until RS.EOF
    iRow = iRow + 1
    For iCol = 1 To UBound(vFields)
        If RS.Fields(vFields(iCol)).Type = 12 Then
             If Not IsNull(RS.Fields(vFields(iCol))) Then
                vData = RS.Fields(vFields(iCol)) ' vData is declared as a Variant
                wks.Cells(iRow, iCol) = vData(0) & "" ' only captures first array element
             End If
        Else
            wks.Cells(iRow, iCol) = RS.Fields(vFields(iCol)).Value & ""
        End If
    Next iCol
    RS.MoveNext
Loop