如何用VBA提取Word特定内容并另存为对应命名的PDF

核心修改说明 #

• 替换原文件名生成逻辑，改为提取三类指定内容
• 将保存格式从.docx改为.pdf
• 优化节内容复制后的格式保留逻辑
• 添加正则匹配提取特定编码（可根据实际编码格式调整）

完整修改后代码 #

Sub ExtractAndSaveAsPDF()
    Dim dlgFile As FileDialog
    Dim objDoc As Document, objDocAdded As Document
    Dim strFolder As String
    Dim nSectionNum As Integer
    Dim strFullName As String, strLocation As String, strCode As String
    Dim rngSection As Range
    Dim regex As Object
    
    ' 初始化正则对象用于提取编码（示例格式：XXX-XXXX，可按需修改）
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "([A-Z0-9]{3}-[A-Z0-9]{4})"
    regex.Global = False
    
    Set objDoc = ActiveDocument
    
    ' 选择PDF保存文件夹
    Set dlgFile = Application.FileDialog(msoFileDialogFolderPicker)
    With dlgFile
        If .Show = -1 Then
            strFolder = .SelectedItems(1) & "\"
        Else
            MsgBox "请选择保存文件夹！"
            Exit Sub
        End If
    End With
    
    ' 遍历文档每一节
    For nSectionNum = 1 To objDoc.Sections.Count
        Set rngSection = objDoc.Sections(nSectionNum).Range
        ' 复制当前节到新文档并保留原格式
        Set objDocAdded = Documents.Add
        rngSection.Copy
        objDocAdded.Range.PasteAndFormat wdFormatOriginalFormatting
        
        ' 提取第二行的姓名（姓氏+名字）
        With objDocAdded.Paragraphs(2).Range
            .End = .End - 1 ' 移除段落标记
            strFullName = Trim(.Text)
        End With
        
        ' 提取第5/6行的地点（优先取第5行，为空则取第6行）
        strLocation = Trim(objDocAdded.Paragraphs(5).Range.Text)
        If strLocation = "" Then
            strLocation = Trim(objDocAdded.Paragraphs(6).Range.Text)
        End If
        strLocation = Replace(strLocation, vbCr, "") ' 清除换行符
        
        ' 提取文本中的特定编码
        Set matches = regex.Execute(objDocAdded.Range.Text)
        strCode = IIf(matches.Count > 0, matches(0).Value, "无编码")
        
        ' 组合并清洗文件名（替换非法字符）
        Dim strFileName As String
        strFileName = strFullName & "_" & strLocation & "_" & strCode
        ' 替换Windows文件名禁用字符
        strFileName = Replace(strFileName, "/", "-")
        strFileName = Replace(strFileName, "\", "-")
        strFileName = Replace(strFileName, ":", "-")
        strFileName = Replace(strFileName, "*", "-")
        strFileName = Replace(strFileName, "?", "-")
        strFileName = Replace(strFileName, """", "-")
        strFileName = Replace(strFileName, "<", "-")
        strFileName = Replace(strFileName, ">", "-")
        strFileName = Replace(strFileName, "|", "-")
        
        ' 导出为PDF
        objDocAdded.ExportAsFixedFormat _
            OutputFileName:=strFolder & strFileName & ".pdf", _
            ExportFormat:=wdExportFormatPDF, _
            OpenAfterExport:=False
        
        ' 关闭临时文档，不保留docx副本
        objDocAdded.Close SaveChanges:=wdDoNotSaveChanges
    Next nSectionNum
    
    MsgBox "所有节已成功保存为PDF！", vbInformation
End Sub

关键部分说明 #

1. 编码提取：正则表达式可根据实际编码规则调整，比如如果编码是纯数字8位，就把Pattern改成"\d{8}"。
2. 地点提取：默认优先读取第5行，若为空则取第6行，可根据文档实际结构调整段落序号。
3. 文件名处理：自动替换Windows系统不允许的特殊字符，避免保存失败。
4. PDF导出：直接通过ExportAsFixedFormat生成PDF，无需保留临时docx文件，提升效率。

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