更换笔记本后从Active Directory取数的VBA宏失效求助

问题背景 #

更换笔记本后，原本正常运行的从AD获取数据的VBA宏失效，旧设备仍可正常使用。已核对并启用所有引用，调试时发现ldapstr为空（旧设备正常），执行Set x = GetObject(ldapstr)时触发运行时错误-2147023541（8007054b），提示："Automation Error The Specified domain either does not exist or could not be contacted." 需要通过Signum获取AD多列信息，需调整代码使用ADODB.Connection方式。

解决方案 #

核心调整：用ADODB查询替代GetObject绑定 #

原代码直接通过LDAP路径绑定AD对象的方式在新设备上可能存在域连接或权限问题，改用ADODB执行LDAP查询更稳定，步骤如下：

• 确保引用ADODB库：在VBA编辑器中，依次点击「工具」→「引用」，勾选「Microsoft ActiveX Data Objects 6.1 Library」（或对应版本）。
• 替换AD数据获取逻辑：将原代码中Set x = GetObject(ldapstr)及后续的x.GetInfoEx、x.Get部分，替换为ADODB查询逻辑。

修改后的完整代码 #

Public Sub UpdateResourceInfoNew()
    Application.Calculation = xlCalculationManual
    Dim auxDoc As New MSHTML.HTMLDocument, HTMLDoc As MSHTML.HTMLDocument
    Dim rw As IHTMLTableRow
    Dim table1 As IHTMLTable
    Dim lo As Excel.ListObject
    Dim lr As Excel.ListRow
    Dim rng As Range
    Dim col As Column
    Dim signum, name, ldapBaseDN, relation As String
    Dim urlText As Variant
    Dim keyVal As Variant
    Dim wb As Workbook
    Dim ws As Worksheet
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("ASSIGNMENTS")
    
    Dim responseDict As Dictionary
    On Error Resume Next
    
    Dim answer As Integer
    answer = MsgBox("Did you updated the Authorization Key in sheet ?", vbQuestion + vbYesNo)
    
    If answer = vbYes Then
    
        Set lo = ActiveWorkbook.Worksheets("ASSIGNMENTS").ListObjects("ASSIGNMENTS")
        ' AD连接相关变量
        Dim conn As ADODB.Connection
        Dim rs As ADODB.Recordset
        Dim adCmdText As Long, adSearchScopeSubtree As Long
        adCmdText = 1
        adSearchScopeSubtree = 2
        ' 定义AD基础DN，替换为你的域结构
        ldapBaseDN = "OU=CA,OU=User,OU=P001,OU=ID,OU=Data,DC=XXXXXXXX,DC=se"
        
        For Each lr In lo.ListRows
            Set rng = lr.Range
            signum = UCase(rng.Cells.Columns(lo.ListColumns("SIGNUM").Index).Value)
            name = rng.Cells.Columns(lo.ListColumns("NAME").Index).Value
            updateFlag = rng.Cells.Columns(lo.ListColumns("UPDATE_RES_INFO").Index).Value
            
            If signum <> "" And updateFlag = 1 Then
                ' 初始化AD连接
                Set conn = New ADODB.Connection
                conn.Provider = "ADsDSOObject"
                conn.Open "Active Directory Provider"
                
                ' 构建LDAP查询语句，根据Signum查询用户
                Dim query As String
                query = "<LDAP://" & ldapBaseDN & ">;(CN=" & signum & ");" & _
                        "CN,displayName,givenName,sn,mail,homePhone,title,department,company,l,country;" & _
                        "subtree"
                
                Set rs = New ADODB.Recordset
                rs.Open query, conn, adOpenStatic, adLockReadOnly, adCmdText
                
                If Not rs.EOF Then
                    ' 读取AD数据并写入表格
                    rng.Cells.Columns(lo.ListColumns("SIGNUM").Index).Value = UCase(rs("CN").Value)
                    rng.Cells.Columns(lo.ListColumns("NAME").Index).Value = Application.WorksheetFunction.Proper(rs("displayName").Value)
                    rng.Cells.Columns(lo.ListColumns("RELATION").Index).Value = Application.WorksheetFunction.Proper(rs("homePhone").Value)
                    rng.Cells.Columns(lo.ListColumns("TITLE").Index).Value = rs("title").Value
                    rng.Cells.Columns(lo.ListColumns("DEPARTMENT").Index).Value = UCase(rs("department").Value)
                    rng.Cells.Columns(lo.ListColumns("COMPANY").Index).Value = UCase(rs("company").Value)
                    rng.Cells.Columns(lo.ListColumns("COUNTRY").Index).Value = UCase(rs("country").Value)
                    rng.Cells.Columns(lo.ListColumns("LAST NAME").Index).Value = Application.WorksheetFunction.Proper(rs("sn").Value)
                    rng.Cells.Columns(lo.ListColumns("FIRST NAME").Index).Value = Application.WorksheetFunction.Proper(rs("givenName").Value)
                    rng.Cells.Columns(lo.ListColumns("E-MAIL").Index).Value = rs("mail").Value
                    rng.Cells.Columns(lo.ListColumns("HOME BASE").Index).Value = UCase(rs("l").Value)
                    rng.Cells.Columns(lo.ListColumns("UPDATE_RES_INFO").Index).Value = 2
                    
                    ' 原有的Signum API调用部分保留
                    Set responseDict = New Dictionary
                    url_prefix = "XXXXXXX"
                    
                    url_suffix = signum_rng
                    
                    Application.DisplayAlerts = False
                    
                    On Error Resume Next
                    
                    Dim returnVal As String
                    
                    Dim httpObject As Object, item As Object
                    Set httpObject = CreateObject("MSXML2.XMLHTTP")
                    
                    URL = url_prefix & Trim(signum)
                    
                    sAuthorization = Worksheets("Authentication key").Range("G4").Value
                    
                    httpObject.Open "GET", URL, False
                    httpObject.setRequestHeader "Authorization", sAuthorization & EncodeBase64
                    httpObject.Send
                    sGetResult = httpObject.responseText
                    
                    With CreateObject("MSXML2.XMLHTTP")
                        .Open "GET", URL, False
                        .Send
                        urlText = Split(Replace(Replace(Replace(Replace(.responseText, "{", ""), "[", ""), "}", ""), "]", ""), ",""")
                    End With
                    
                    responseDict.RemoveAll
                    
                    For i = 0 To UBound(urlText)
                        urlText(i) = Replace(urlText(i), Chr(34), "")
                        keyVal = Split(urlText(i), ":")
                        responseDict.Add keyVal(0), keyVal(1)
                    Next i
                    
                    If Split(urlText(34), ":")(1) <> "null" Or Len(Split(urlText(34), ":")(1)) <> 0 Then
                        rng.Cells.Columns(lo.ListColumns("PERSONNEL NUMBER").Index).Value = Split(urlText(34), ":")(1)
                    End If
                    
                    If Split(urlText(11), ":")(1) <> "null" Or Len(Split(urlText(11), ":")(1)) <> 0 Then
                        rng.Cells.Columns(lo.ListColumns("JOB ROLE").Index).Value = Split(urlText(11), ":")(1)
                    End If
                    
                    If Split(urlText(30), ":")(1) <> "null" Or Len(Split(urlText(30), ":")(1)) <> 0 Then
                        rng.Cells.Columns(lo.ListColumns("POSITION NAME").Index).Value = Split(urlText(30), ":")(1)
                    End If
                    
                    If Split(urlText(4), ":")(1) <> "null" Or Len(Split(urlText(4), ":")(1)) <> 0 Then
                        rng.Cells.Columns(lo.ListColumns("LINE MANAGER").Index).Value = Split(urlText(4), ":")(1)
                    End If
                    
                    If Split(urlText(38), ":")(1) <> "null" Or Len(Split(urlText(38), ":")(1)) <> 0 Then
                        rng.Cells.Columns(lo.ListColumns("COUNTRY").Index).Value = Split(urlText(38), ":")(1)
                    End If
                    
                    If Split(urlText(22), ":")(1) <> "null" Or Len(Split(urlText(22), ":")(1)) <> 0 Then
                        rng.Cells.Columns(lo.ListColumns("MOBILE").Index).Value = Split(urlText(22), ":")(1)
                    End If
                    
                    If Split(urlText(32), ":")(1) <> "null" Or Len(Split(urlText(32), ":")(1)) <> 0 Then
                        rng.Cells.Columns(lo.ListColumns("COST CENTRE").Index).Value = Split(urlText(32), ":")(1)
                    End If
                    
                    Application.DisplayAlerts = True
                Else
                    ' 未找到对应Signum的AD用户，标记为3
                    rng.Cells.Columns(lo.ListColumns("UPDATE_RES_INFO").Index).Value = 3
                End If
                
                ' 关闭记录集和连接
                rs.Close
                conn.Close
                Set rs = Nothing
                Set conn = Nothing
            End If
        
            DoEvents
        Next lr
        
        MsgBox ("RP Updated")
    
    Else
        MsgBox "Please update the Authorization Key first"
    End If

    Application.Calculation = xlCalculationAutomatic
End Sub

额外排查点 #

• 确认新设备已加入目标域（DC=XXXXXXXX,DC=se），且能正常访问域控制器
• 检查LDAP路径中的OU结构是否与旧设备一致，避免因OU层级变更导致查询失败
• 确保当前用户拥有访问AD用户信息的权限

内容的提问来源于stack exchange，提问作者Negi1984