VBA中如何可靠检测Word、PPTX文档是否密码保护？

方案1：解析OXML压缩包结构（推荐，无Office依赖、稳定高效） #

docx/pptx本质是ZIP压缩包，加密保护的文件会有特定结构特征：

• 存在EncryptionInfo.xml文件
• 原有的主内容文件（如docx的word/document.xml、pptx的ppt/presentation.xml）会被替换为EncryptedPackage文件

以下是实现代码，无需启动Office应用，批量检测时性能和稳定性大幅提升：

Function IsOXMLPasswordProtected(filePath As String) As Boolean
    Dim shellApp As Object
    Dim zipFolder As Object
    Dim hasEncryptionInfo As Boolean
    Dim hasMainContent As Boolean
    Dim mainContentPath As String
    
    ' 根据文件后缀设置主内容文件路径
    Select Case LCase(Right(filePath, 4))
        Case "docx": mainContentPath = "word/document.xml"
        Case "pptx": mainContentPath = "ppt/presentation.xml"
        Case Else:
            IsOXMLPasswordProtected = False
            Exit Function
    End Select
    
    On Error Resume Next
    Set shellApp = CreateObject("Shell.Application")
    Set zipFolder = shellApp.Namespace(Left(filePath, Len(filePath) - 4) & ".zip") ' 临时将后缀视为zip
    
    ' 检查是否存在加密信息文件
    If Not zipFolder.ParseName("EncryptionInfo.xml") Is Nothing Then
        hasEncryptionInfo = True
    End If
    
    ' 检查是否存在正常的主内容文件（加密文件无此路径）
    If Not zipFolder.ParseName(mainContentPath) Is Nothing Then
        hasMainContent = True
    End If
    
    ' 加密文件的判定：存在加密信息 且 无正常主内容文件
    IsOXMLPasswordProtected = hasEncryptionInfo And Not hasMainContent
    
    ' 释放资源
    Set zipFolder = Nothing
    Set shellApp = Nothing
    On Error GoTo 0
End Function

方案2：优化Office自动化方法（修复原方法的稳定性问题） #

原方法的错误主要是COM对象未正确释放、批量操作时Office进程资源泄漏导致的。以下是优化后的代码，严格管理对象生命周期：

Function IsOfficeFileProtected(filePath As String) As Boolean
    Dim appObj As Object
    Dim docObj As Object
    Dim errNumber As Long
    
    IsOfficeFileProtected = False
    
    On Error Resume Next
    ' 根据文件类型创建对应的应用对象
    Select Case LCase(Right(filePath, 4))
        Case "docx": Set appObj = CreateObject("Word.Application")
        Case "pptx": Set appObj = CreateObject("PowerPoint.Application")
        Case Else: Exit Function
    End Select
    appObj.Visible = False ' 后台运行
    
    ' 尝试用错误密码打开文件
    Select Case LCase(Right(filePath, 4))
        Case "docx": Set docObj = appObj.Documents.Open(filePath, PasswordDocument:="invalidpw")
        Case "pptx": Set docObj = appObj.Presentations.Open(filePath, WithWindow:=False, Password:="invalidpw")
    End Select
    
    errNumber = Err.Number
    ' 密码错误的错误号：Word是5408，PowerPoint是280
    If errNumber = 5408 Or errNumber = 280 Then
        IsOfficeFileProtected = True
    End If
    
    ' 强制关闭文档和应用，释放资源
    On Error Resume Next
    If Not docObj Is Nothing Then
        docObj.Close SaveChanges:=False
        Set docObj = Nothing
    End If
    If Not appObj Is Nothing Then
        appObj.Quit
        Set appObj = Nothing
    End If
    On Error GoTo 0
End Function

优化点说明 #

• 每次操作后强制关闭Office应用并释放对象，避免进程残留
• 明确判断密码错误的特定错误号，而非依赖通用错误提示
• 后台运行Office应用，避免界面干扰

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