Question

我正在编写一个与新模板一起使用的加载项。其中一个工具应该遍历整个演示文稿，并用新的默认字体替换每个字体。这工作正常，但我遇到unicode字体的问题。

演示文稿中的某些形状似乎有一个链接到它们的unicode字体，但不是文本的一部分（可能是父形状字体？）。当我替换字体时，文本被更改，但我仍然在我的演示文稿中嵌入了unicode字体。当我尝试检测使用VBA时，找不到它们。如果我将文本（无格式化）复制到新文本框，则unicode字体会消失，因此它们会以某种方式与形状格式相关联。

我尝试过更改.NameAscii / .NameComplexScript / .NameFarEast＆amp; .NameOther，这也不起作用。有没有办法访问形状的父字体？

E.g。 shp.textframe.parent.font.name =

我当前的宏工作正常，但我需要解决这个问题，因为当我保存嵌入式unicode字体时，我的演示文稿很大。或者，有没有办法只在演示文稿中嵌入某些字体？

任何帮助都会非常感激！我在下面粘贴了我的宏：

Sub ChangeFont()

Dim x, y, a, b As Integer
Dim s As Slide
Dim shp As Shape
Dim ppt As Presentation
Dim pp2 As Presentation

Set ppt = ActivePresentation

On Error Resume Next

For x = 1 To ppt.Slides.Count
    For y = 1 To ppt.Slides(x).Shapes.Count

    Set shp = ppt.Slides(x).Shapes(y)

        If shp.HasTextFrame Then
            shp.TextFrame.TextRange.Font.Name = "FontA"

        ElseIf shp.Type = msoChart Then
            On Error Resume Next
            shp.Chart.ChartTitle.Format.TextFrame2.TextRange.Font.Name = "FontA"
            shp.Chart.Legend.Format.TextFrame2.TextRange.Font.Name = "FontA"
            shp.Chart.DataTable.Format.TextFrame2.TextRange.Font.Name = "FontA"


        ElseIf shp.Type = msoTable Then
            For a = 1 To shp.Table.Rows.Count
                For b = 1 To shp.Table.Columns.Count
                    shp.Table.Cell(a, b).Shape.TextFrame.TextRange.Font.Name = "FontA"
                Next b
            Next a

        End If

        ChangeFontsubs ppt.Slides(x).Shapes(y)

    Next y
Next x

MsgBox "Font changed to FontA", vbOKOnly

End Sub

Sub ChangeFontsubs(tshp As Shape)

Dim j As Integer

On Error Resume Next

If tshp.HasTextFrame Then
    tshp.TextFrame.TextRange.Font.Name = "FontA"       
End If

Select Case tshp.Type
Case msoGroup, msoSmartArt
    For j = 1 To tshp.GroupItems.Count
        ChangeFontsubs tshp.GroupItems.Item(j)
    Next j
End Select

End Sub

Answer 1

正如史蒂夫所说，用户文字可以出现在很多不同的地方，例如：

相片数：

占位符
形状
表
图表
的SmartArt
评论
备注窗格

大师：

幻灯片（和布局名称）
讲义
注释

其他：

形状名称
部分名称
自定义显示名称
自定义文档属性

用SBCS（单字节字符集，0-255）字符替换DBCS（双字节字符集0-65535）字符的问题是提出问题＆＃34;应该用什么代替？＆＃34 ;.例如，这是日语中的东京：东京这两个字符分别是Unicode 26481和20140。 SBCS只有255个可能的字符而不是DBCS的65535，因此无法将DBCS映射到SBCS。

此宏将检测演示文稿的所有幻灯片中是否存在任何标准形状对象中的任何DBCS字符，并且可用于接受PowerPoint文件中所有上述可能出现的文本的文本范围：

' Nothing passed : Queries every character in every shape in every slide within the presentation for Double Byte Character Set font occurrence
' TextRange passed : Queries every character within the text range for Double Byte Character Set font occurrence
' Returns true if any DBC is found and outputs occurences to the immediate window
Public Function TextRangeHasDBC(Optional trText As TextRange) As Boolean
  Dim oSld As Slide
  Dim oShp As Shape
  Dim cntrChr As Integer
  If trText Is Nothing Then
    For Each oSld In ActivePresentation.Slides
      For Each oShp In oSld.Shapes
        If oShp.HasTextFrame Then
          If oShp.TextFrame.HasText Then
            With oShp.TextFrame.TextRange
              For cntrChr = 1 To Len(.Text)
                If AscW(.Characters(cntrChr, 1)) > 255 Then
                  Debug.Print "DBC found. Slide : "; CStr(oSld.SlideIndex); ", Shape : "; oShp.Name; ", Character "; CStr(cntrChr); " = Unicode "; CStr(AscW(.Characters(cntrChr, 1)))
                  TextRangeHasDBC = True
                End If
              Next
            End With
          End If
        End If
      Next
    Next
  Else
    With trText
      For cntrChr = 1 To Len(.Text)
        If AscW(.Characters(cntrChr, 1)) > 255 Then
          Debug.Print "DBC found. Slide : "; CStr(.Parent.Parent.Parent.SlideIndex); ", Shape : "; .Parent.Parent.Name; ", Character "; CStr(cntrChr); " = Unicode "; CStr(AscW(.Characters(cntrChr, 1)))
          TextRangeHasDBC = True
        End If
      Next
    End With
  End If
End Function

Answer 2

此问题的唯一解决方案是在XML级别上进行。因此，请将PPT文件另存为XML，然后将其视为一个长字符串搜索并替换所需的字体。

使用VBA删除演示文稿中不在文本中的unicode字体（PowerPoint 2013）

2 个答案: