WPS文字，选中文本的字体在全文中批量替换

传统的方法是批量替换时选字体，再选替换字体，太麻烦。以下代码实现鼠标选中的文本，获得其字体，再弹出系统换字体的对话框，只需要选即将替换字体后，就全篇替换，实乃偷懒神器。

Sub 选中文字字体全篇替换()
    ' 功能：获取选中文字的中文字体 → 弹出字体对话框选择新字体 → 替换全文中所有使用该中文字体的文字（西文字体不受影响）
    
    Dim oldFont As String, newFont As String
    Dim dlg As Dialog
    
    ' --- 1. 检查是否选中文字 ---
    If Selection.Type = wdSelectionIP Then
        MsgBox "请先在文档中选中一段文字，以便获取要替换的字体。", vbExclamation, "提示"
        Exit Sub
    End If
    
    ' --- 2. 获取选中文字的中文字体名 ---
    oldFont = Selection.Font.NameFarEast
    ' 若中文字体为空（纯英文选中），则尝试使用通用字体名
    If oldFont = "" Then oldFont = Selection.Font.Name
    If oldFont = "" Then
        MsgBox "无法获取选中文字的字体，请重新选择。", vbExclamation, "出错"
        Exit Sub
    End If
    
    ' --- 3. 弹出字体选择对话框，预设当前字体 ---
    Set dlg = Application.Dialogs(wdDialogFormatFont)
    With dlg
        .Font = oldFont               ' 默认显示当前字体
        If .Show = -1 Then            ' 用户点击确定
            newFont = .Font
        Else
            MsgBox "已取消替换操作。", vbInformation, "取消"
            Exit Sub
        End If
    End With
    
    ' --- 4. 新旧字体相同则无需替换 ---
    If StrComp(oldFont, newFont, vbTextCompare) = 0 Then
        MsgBox "您选择的新字体与当前字体相同，无需替换。", vbInformation, "提示"
        Exit Sub
    End If
    
    ' --- 5. 在全文档中执行替换（基于中文字体） ---
    Dim rng As Range
    Set rng = ActiveDocument.Content
    
    ' 关闭屏幕刷新，提高执行速度并避免闪烁
    Application.ScreenUpdating = False
    
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        
        ' ★ 关键：只按中文字体查找，不限制西文字体（参考录制宏的 .NameAscii = ""）
        .Font.NameFarEast = oldFont
        ' 明确清空其他字体限制，确保查找不受干扰
        .Font.NameAscii = ""
        .Font.NameOther = ""
        .Font.NameBi = ""
        
        ' 替换时不改动西文字体，只改中文字体
        .Replacement.Font.NameFarEast = newFont
        
        ' 其余查找参数（与录制宏风格一致）
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchWholeWord = False
        .MatchFuzzy = False
        
        ' 执行全部替换
        .Execute Replace:=wdReplaceAll
    End With
    
    Application.ScreenUpdating = True
    
    ' --- 6. 完成提示 ---
    MsgBox "已完成！全文中使用「" & oldFont & "」的文字（中文字体）已全部替换为「" & newFont & "」。", vbInformation, "替换完成"
    
    ' 可选：将光标移至文档开头，方便查看
    ActiveWindow.ScrollIntoView ActiveDocument.Range(0, 0), True
End Sub