PPT 排版神器:一键自动区分中英字体,几十页 3 秒搞定

'主程序

Sub AllFontTwoStyle()

Dim sld As Slide, shp As Shape, subShp As Shape

Dim tbl As Table, cell As Cell

Dim i As Long, j As Long

For Each sld In ActivePresentation.Slides

For Each shp In sld.Shapes

On Error Resume Next

If shp.Type = msoGroup Then

For Each subShp In shp.GroupItems

Call SetFontMix(subShp)

Next subShp

ElseIf shp.HasTable Then

Set tbl = shp.Table

For i = 1 To tbl.Rows.Count

For j = 1 To tbl.Columns.Count

Call SetFontMix(tbl.Cell(i, j).Shape)

Next j

Next i

Else

Call SetFontMix(shp)

End If

On Error GoTo 0

Next shp

Next sld

MsgBox "替换完成：中文=微软雅黑，英文/数字=Calibri", vbInformation

End Sub

'区分中英文自动换字体

Private Sub SetFontMix(shp As Shape)

Dim tr As TextRange, ch As TextRange

Dim k As Long

If Not (shp.HasTextFrame And shp.TextFrame.HasText) Then Exit Sub

Set tr = shp.TextFrame.TextRange

'先统一东亚字体：中文微软雅黑

tr.Font.NameFarEast = "微软雅黑"

'逐个字符判断：字母数字改用Calibri

For k = 1 To tr.Length

Set ch = tr.Characters(k, 1)

If IsLetterOrNum(ch.Text) Then

ch.Font.Name = "Calibri"

Else

ch.Font.Name = "微软雅黑"

End If

Next k

End Sub

'判断是否为英文/数字

Private Function IsLetterOrNum(s As String) As Boolean

Dim c As Integer

c = Asc(UCase(s))

'A-Z 或者 0-9

IsLetterOrNum = ((c >= 65 And c <= 90) Or (c >= 48 And c <= 57))

End Function