vba - 如何在 Powerpoint 2007 VBA 中检测主题字体？

Question

有谁知道如何使用 VBA 检测 Powerpoint 2007 幻灯片对象中主题字体的使用？如果Shape.TextFrame.TextRange.Font.Name字体名称显示为简单名称（例如：“Arial”），无论该字体是被指定为固定名称还是主题名称（可能随文档主题而变化）。我在对象模型中看不到任何其他将名称标记为与主题相关的属性（例如ObjectThemeColor颜色）。

谢谢！

Answer 1

没有直接的方法（我知道），但是您可以使用 If/Then 进行检查：

Sub checkthemeFont()
    Dim s As Shape
    Set s = ActivePresentation.Slides(1).Shapes(1)
    Dim f As Font
    Set f = s.TextFrame.TextRange.Font

    Dim themeFonts As themeFonts
    Dim majorFont As ThemeFont

    Set themeFonts = ActivePresentation.SlideMaster.Theme.ThemeFontScheme.MajorFont
    Set majorFont = themeFonts(msoThemeLatin)

    If f.Name = majorFont Then
        Debug.Print f.Name
    End If
End Sub

Answer 2

感谢@tobriand 的想法，这里有一个实现，它报告是否有任何占位符设置为硬编码字体而不是主题中的字体：

Option Explicit

' =================================================================================
' PowerPoint VBA macro to check if all text-supporting placeholders are set
' to use one of the two theme fonts or are "hard coded".
' Checks all slide masters in the active presentation.
' Author : Jamie Garroch
' Company : BrightCarbon Ltd. (https://brightcarbon.com/)
' Date : 05MAR2020
' =================================================================================
Public Sub CheckMastersUseThemeFonts()
  Dim oDes As Design
  Dim oCL As CustomLayout
  Dim oShp As Shape
  Dim tMinor As String, tMajor As String
  Dim bFound As Boolean
  Dim lMasters, lLayouts, lPlaceholders

  ' If you use Arial, change this to any font not used in your template
  Const TEMP_FONT = "Arial"

  For Each oDes In ActivePresentation.Designs
    lMasters = lMasters + 1

    ' Save the current theme fonts before changing them
    With oDes.SlideMaster.Theme.ThemeFontScheme
      tMajor = .MajorFont(msoThemeLatin).Name
      tMinor = .MinorFont(msoThemeLatin).Name
      .MajorFont(msoThemeLatin).Name = TEMP_FONT
      .MinorFont(msoThemeLatin).Name = TEMP_FONT
    End With

    ' Check if any are not set to the temporary font, indicating hard coding
    For Each oCL In oDes.SlideMaster.CustomLayouts
      lLayouts = lLayouts + 1
      For Each oShp In oCL.Shapes
        If oShp.Type = msoPlaceholder Then lPlaceholders = lPlaceholders + 1
        If oShp.HasTextFrame Then
          Select Case oShp.TextFrame.TextRange.Font.Name
            Case "Arial"
            Case Else
              bFound = True
              Debug.Print oShp.TextFrame.TextRange.Font.Name, oDes.Name, oCL.Name, oShp.Name
          End Select
        End If
      Next
    Next

    ' Restore the original fonts
    With oDes.SlideMaster.Theme.ThemeFontScheme
      .MajorFont(msoThemeLatin).Name = tMajor
      .MinorFont(msoThemeLatin).Name = tMinor
    End With

  Next

  If bFound Then
    MsgBox "Some placeholders are not set to use the theme fonts. Press Alt+F11 to see them in the Immediate pane.", vbCritical + vbOKOnly, "BrightSlide - Master Theme Fonts"
  Else
    MsgBox "All placeholders are set to use the theme fonts.", vbInformation + vbOKOnly, "BrightSlide - Master Theme Fonts"
  End If

  ' Provide some stats on what was checked
  Debug.Print "Masters: " & lMasters
  Debug.Print "Layouts: " & lLayouts
  Debug.Print "Placeholders: " & lPlaceholders
End Sub