论文公式排版神器：一键将公式字母变斜体，数字保持正体，字体调整为Times New Roman！

Sub 调整全文公式新罗马10.5()
' 1. 设置公式字体为Times New Roman，字号10.5
' 2. 设置英文字母为斜体
Dim oMath As oMath
Dim oRange As Range, charRange As Range
Dim oShape As InlineShape
Dim i As Long, j As Long, k As Long
Dim formulaCount As Long, numChanged As Long
Dim result As VbMsgBoxResult
Dim oEq As Object, eqText As String
' 统计公式数量
formulaCount = ActiveDocument.OMaths.count
' 询问确认
result = MsgBox("即将处理全文档所有公式。" & vbCrLf & _
"将执行以下操作：" & vbCrLf & _
"1. 设置字体为 Times New Roman，字号10.5" & vbCrLf & _
"2. 设置英文字母为斜体" & vbCrLf & _
"3. 设置所有数字为正体（包括根号下、分式中等）" & vbCrLf & vbCrLf & _
"共找到 " & formulaCount & " 个公式对象。" & vbCrLf & _
"是否继续？", vbYesNo + vbQuestion, "确认")
If result = vbNo Then Exit Sub
' 禁用屏幕刷新以提高性能
Application.ScreenUpdating = False
' 初始化计数器
numChanged = 0
' === 处理主文档中的公式对象 ===
For Each oMath In ActiveDocument.OMaths
' 设置整个公式的基本字体
With oMath.Range.Font
.name = "Times New Roman"
.Size = 10.5
End With
' 使用递归方法处理公式中的所有字符
Call ProcessMathRange(oMath.Range, numChanged)
Next oMath
' === 处理内嵌公式（Equation.3 旧版公式）===
For Each oShape In ActiveDocument.InlineShapes
If oShape.Type = wdInlineShapeEmbeddedOLEObject Then
If oShape.OLEFormat.ClassType = "Equation.3" Then
oShape.Select
' 设置公式基本字体
With Selection.OMaths(1).Range.Font
.name = "Times New Roman"
.Size = 10.5
End With
' 处理内嵌公式
Call ProcessMathRange(Selection.OMaths(1).Range, numChanged)
End If
End If
Next oShape
' 恢复屏幕刷新
Application.ScreenUpdating = True
' 显示完成消息
MsgBox "公式格式设置完成！" & vbCrLf & _
"处理公式数量：" & formulaCount & " 个" & vbCrLf & _
"数字转为正体：" & numChanged & " 个", _
vbInformation, "批量处理完成"
End Sub
' 递归处理公式范围的子过程
Private Sub ProcessMathRange(mathRange As Range, ByRef counter As Long)
Dim i As Long
Dim charRange As Range
Dim charText As String
' 遍历范围内的每个字符
For i = mathRange.Start To mathRange.End - 1
Set charRange = ActiveDocument.Range(i, i + 1)
charText = charRange.text
' 处理英文字母
If charText Like "[A-Za-z]" Then
charRange.Font.Italic = True
' 处理数字0-9
ElseIf charText >= "0" And charText <= "9" Then
charRange.Font.Italic = False
counter = counter + 1
' 处理可能的小数点和负号
ElseIf charText = "." Or charText = "-" Then
' 检查前后字符是否为数字
Dim prevChar As String, nextChar As String
If i > mathRange.Start Then
prevChar = ActiveDocument.Range(i - 1, i).text
Else
prevChar = ""
End If
If i < mathRange.End - 1 Then
nextChar = ActiveDocument.Range(i + 1, i + 2).text
Else
nextChar = ""
End If
' 如果前后是数字，这个字符也应该是正体
If (IsNumeric(prevChar) Or prevChar = "") And IsNumeric(nextChar) Then
charRange.Font.Italic = False
End If
End If
Next i
End Sub

Sub 调整公式内数字为新罗马()
Dim oField As Field
Dim oRange As Range
Dim i As Long
Dim sFormula As String
Dim bInObject As Boolean
Dim sChar As String
' 遍历文档中的所有域（公式通常是EQ域或某些OLE对象）
For Each oField In ActiveDocument.Fields
If oField.Type = wdFieldEmbed Then
' 如果是OLE对象（如公式编辑器创建的公式）
If oField.OLEFormat.ClassType Like "*Equation*" Then
oField.OLEFormat.Object.Select
' 这里需要根据公式编辑器的具体版本调整
' 对于旧版Microsoft Equation 3.0：
On Error Resume Next
Selection.OMaths(1).Range.Select
For i = 1 To Selection.Characters.Count
sChar = Selection.Characters(i).Text
If IsNumeric(sChar) And sChar <> " " Then
With Selection.Characters(i).Font
.Name = "Times New Roman"
.Size = 10.5
End With
End If
Next i
On Error GoTo 0
End If
End If
Next oField
' 处理内联公式（使用Word内置公式编辑器创建的公式）
Dim oOMath As OMath
For Each oOMath In ActiveDocument.OMaths
oOMath.Range.Select
For i = 1 To Selection.Characters.Count
sChar = Selection.Characters(i).Text
If IsNumeric(sChar) And sChar <> " " Then
With Selection.Characters(i).Font
.Name = "Times New Roman"
.Size = 10.5
End With
End If
Next i
Next oOMath
' 处理通过"插入->公式"创建的公式
Dim oShape As Shape
For Each oShape In ActiveDocument.Shapes
If oShape.Type = msoInlineShape Then
If oShape.OLEFormat.ProgID Like "*Equation*" Then
oShape.OLEFormat.Object.Select
For i = 1 To Selection.Characters.Count
sChar = Selection.Characters(i).Text
If IsNumeric(sChar) And sChar <> " " Then
With Selection.Characters(i).Font
.Name = "Times New Roman"
.Size = 10.5
End With
End If
Next i
End If
End If
Next oShape
MsgBox "公式数字格式设置完成！", vbInformation
End Sub