Excel VBA从Active Directory获取大整数属性时遇Error 438错误

问题分析 #

错误438的核心原因有两个：

1. 属性名错误：你代码中指定的expirationTimeAttribute = "usnchanged"并非LAPS密码过期时间的属性，正确属性应为ms-Mcs-AdmPwdExpirationTime
2. 大整数类型处理不当：AD中的ms-Mcs-AdmPwdExpirationTime是64位大整数（Int64），VBA标准数据类型无法直接接收ADODB返回的该类型值，需要通过特定方式读取转换。

解决方案 #

方法一：使用ADSI对象直接读取（推荐） #

这种方式能可靠处理大整数属性，同时简化代码逻辑：

Option Explicit

Public Function GetLapsPasswordExpiration(ByVal computerName As String) As String
    Dim computerADObj As Object
    Dim domainRoot As String
    Dim ldapPath As String
    Dim expTime As Variant
    
    ' 获取域根路径
    domainRoot = GetDomainRoot()
    ' 构造计算机对象的LDAP完整路径
    ldapPath = "LDAP://cn=" & computerName & ",cn=Computers," & domainRoot
    
    On Error Resume Next
    Set computerADObj = GetObject(ldapPath)
    On Error GoTo 0
    
    If Not computerADObj Is Nothing Then
        ' 读取大整数类型的过期时间属性
        expTime = computerADObj.Get("ms-Mcs-AdmPwdExpirationTime")
        If Not IsEmpty(expTime) Then
            ' 将AD时间戳转换为Excel可识别的日期
            ' AD时间戳以100纳秒为单位，起始时间为1601年1月1日
            GetLapsPasswordExpiration = CDate((CLng(expTime) / 864000000000) + #1/1/1601#)
        Else
            GetLapsPasswordExpiration = "LAPS密码未设置"
        End If
    Else
        GetLapsPasswordExpiration = "未找到该计算机对象"
    End If
    
    Set computerADObj = Nothing
End Function

' 实现域根路径获取函数（若已有可忽略）
Private Function GetDomainRoot() As String
    Dim rootDSE As Object
    Set rootDSE = GetObject("LDAP://RootDSE")
    GetDomainRoot = rootDSE.Get("defaultNamingContext")
    Set rootDSE = Nothing
End Function

方法二：修改ADODB查询的处理逻辑 #

若坚持使用ADODB查询，需调整属性读取方式，注意该方式在部分系统可能存在兼容性问题：

Option Explicit

Public Function GetLapsPasswordExpiration(ByVal computerName As String) As String
Dim adoCommand As Object
Dim adoConnection As Object
Dim adoRecordset As Object
Dim searchBase As String
Dim filter As String
Dim expirationTimeAttribute As String

' 修正属性名为LAPS过期时间的正确标识
expirationTimeAttribute = "ms-Mcs-AdmPwdExpirationTime"
searchBase = "<LDAP://" & GetDomainRoot() & ">"
filter = "(&(objectClass=computer)(cn=" & computerName & "))"

Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
Set adoRecordset = CreateObject("ADODB.Recordset")

adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = adoConnection
adoCommand.CommandText = searchBase & ";" & filter & ";" & expirationTimeAttribute & ";subtree"
adoCommand.Properties("Page Size") = 1000
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Searchscope") = 2

Set adoRecordset = adoCommand.Execute

If Not adoRecordset.EOF Then
    Dim expValue As Variant
    expValue = adoRecordset.Fields(expirationTimeAttribute).Value
    If Not IsNull(expValue) Then
        ' 转换AD时间戳为标准日期
        GetLapsPasswordExpiration = CDate((CLng(expValue) / 864000000000) + #1/1/1601#)
    Else
        GetLapsPasswordExpiration = "LAPS密码未设置"
    End If
Else
    GetLapsPasswordExpiration = "Computer not found or LAPS password not set."
End If

' 释放对象
Set adoRecordset = Nothing
Set adoCommand = Nothing
Set adoConnection = Nothing
End Function

Private Function GetDomainRoot() As String
    Dim rootDSE As Object
    Set rootDSE = GetObject("LDAP://RootDSE")
    GetDomainRoot = rootDSE.Get("defaultNamingContext")
    Set rootDSE = Nothing
End Function

关键注意事项 #

• ms-Mcs-AdmPwdExpirationTime的时间戳单位为100纳秒，需除以864000000000（一天的100纳秒总数）后，加上1601年1月1日得到标准日期。
• 确保运行VBA的用户拥有读取AD中计算机对象ms-Mcs-AdmPwdExpirationTime属性的权限，否则会返回空值或权限错误。

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