VBA宏编程批量修改PPT字体

Sub ChangeFont()
    Dim slide As slide
    Dim shape As shape
    
    ' 设置目标字体名称
    Dim newFont As String
    newFont = "新字体名称"  ' 替换为您希望使用的字体名称
    
    ' 遍历每一页
    For Each slide In ActivePresentation.Slides
        ' 遍历每个文本框
        For Each shape In slide.Shapes
            If shape.HasTextFrame Then
                shape.TextFrame.TextRange.Font.Name = newFont
            End If
        Next shape
    Next slide
End Sub

Sub ChangeChineseFont()
    Dim slide As slide
    Dim shape As shape
    
    ' 设置目标字体名称
    Dim newFont As String
    newFont = "新的中文字体名称"  ' 替换为您希望使用的中文字体名称
    
    ' 遍历每一页
    For Each slide In ActivePresentation.Slides
        ' 遍历每个文本框
        For Each shape In slide.Shapes
            If shape.HasTextFrame And IsChineseText(shape.TextFrame.TextRange) Then
                shape.TextFrame.TextRange.Font.Name = newFont
            End If
        Next shape
    Next slide
End Sub

Function IsChineseText(textRange As TextRange) As Boolean
    Dim char As Integer
    IsChineseText = False
    
    For char = 1 To Len(textRange.Text)
        If AscW(Mid(textRange.Text, char, 1)) >= &H4E00 And AscW(Mid(textRange.Text, char, 1)) <= &H9FFF Then
            IsChineseText = True
            Exit Function
        End If
    Next char
End Function