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

我正在编写一个外接程序，以便与新模板一起使用。其中一个工具应该遍历整个演示文稿，并用新的默认字体替换每个字体。这很好，但我在unicode字体方面有问题

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

我已尝试更改.namescii/.NameComplexScript/.namefreast&.NameOther，但这也不起作用。有没有办法访问形状的父字体

例如，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

---

正如Steve所说，用户文本可以出现在许多不同的地方，例如：

幻灯片：

占位符 形状 桌子 图表 字符元素 评论 注释窗格 大师：

幻灯片和版面名称 施舍 笔记 其他：

形状名称 节名 自定义显示名称 自定义文档属性 将DBCS双字节字符集0-65535字符替换为SBCS单字节字符集0-255字符的问题在于，这就提出了一个问题：应该用什么替换它？。例如，这是日语中的Tokyo一词：東京 这两个字符分别是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

---

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

您可能需要编辑问题以澄清问题。monotype字体是什么意思？Monotype是一家字体公司，但据我所知，它不是一种特定的字体。你是说UNICODE字体吗？PowerPoint不允许将unicode或双字节字体替换为非unicode或单字节字体。您可能可以通过修改底层XML来解决这个问题，但这不是儿戏。谢谢——我指的是unicode/双字节字体。有没有办法只嵌入某些字体？问题是，当嵌入unicode字体时，会使演示文稿变得巨大。或者，一种对宏进行编码的方法，该方法检测unicode字体在演示文稿中的每个形状/图表/表格中的使用位置，但却找不到它，因此，人们很容易找到并删除它。从理论上讲，编写这种代码是可能的，但考虑到文本可以隐藏的位置，这将非常繁琐。在字体中格式化的单个空格可以触发嵌入。哎哟你不能只看包含文本的形状；您必须查看.TextFrame.TextRange.Runs.Count，并检查每个.Run的字体。