修改Word VBA代码 提取“Patient Name:”后2词生成保存文件名

核心需求 #

• 现有功能：编辑完Word病历后运行VBA，自动在指定路径保存PDF、Word双格式副本，同时触发打印
• 原有命名规则：当前日期 + 文档开头前2个单词，必须把患者姓名放在文档最开头，不符合规范病历书写要求
• 目标命名规则：当前日期 + 文档中"Patient Name:"文本后的前2个单词（即患者姓名），适配标准病历模板

参考病历格式示例 #

尊敬的xyz医生：
很荣幸蒂莫西·道尔顿先生前来我的诊所就诊，详情如下：

Patient Name: Timothy Dalton
年龄：125岁
性别：男
.....
...
...
......
......

此致
Yes医生

修改后完整可运行代码 #

Sub PDF_Sv_And_Pr()
    Dim findRng As Range
    Dim patientNameRng As Range
    Dim patientName As String
    Dim Dt As String
    
    ' 查找文档中的Patient Name标签
    Set findRng = ActiveDocument.Content
    With findRng.Find
        .ClearFormatting
        .Text = "Patient Name:"
        .Forward = True
        .Wrap = wdFindStop
        ' 未找到标签时弹出提示并终止运行
        If Not .Execute Then
            MsgBox "未检测到""Patient Name:""字段，请检查病历内容", vbExclamation
            Exit Sub
        End If
    End With
    
    ' 提取标签后2个单词作为患者姓名
    Set patientNameRng = ActiveDocument.Range(Start:=findRng.End, End:=findRng.End)
    patientNameRng.MoveEnd wdWord, 2
    patientName = Trim(patientNameRng.Text)
    
    ' 生成日期前缀
    Dt = Format(Now(), "YYYY-MM-DD")
    
    ' 保存双格式副本
    With ActiveDocument
        .SaveAs2 "G:\My Drive\Clinic Visits\" & Dt & " " & patientName & ".pdf", _
            FileFormat:=wdFormatPDF
        .SaveAs2 "G:\My Drive\Clinic Visits\" & Dt & " " & patientName & ".docx", _
            FileFormat:=wdFormatDocumentDefault
    End With

    ' 自动打印
    ActiveDocument.PrintOut
End Sub

关键修改说明 #

• 移除了原代码直接取文档前2个单词的命名逻辑
• 新增文本定位逻辑：自动搜索文档内的Patient Name:标签位置，不受标签所在段落位置限制
• 从标签末尾开始向后提取2个单词作为文件名的姓名部分，自动去除首尾多余空格
• 新增容错判断：如果病历中漏写Patient Name:标签，会弹出明确提示，避免代码运行出错
• 原有保存路径、双格式保存、自动打印的逻辑完全保留，无需额外调整

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