游ゴシック Mediumの疑似ボールド体を游ゴシック BoldにするVBA

背景

游ゴシック MediumはPowerPoint上で太字(ボールド体)にしても疑似ボールド体にしかならず，游ゴシック Boldになってくれません．¹ いちいちフォントを手作業で変えるのは面倒なので自動で置換してくれるVBAを作りました．

コード

VBAを書くの初めてなので，コードが汚いのはご容赦ください．バグ等ありましたら報告お願いします．

Public Const FROM_FONT As String = "游ゴシック Medium"
Public Const TO_FONT As String = "游ゴシック"

Public Sub YuGothicMediumBoldReplacer()
    Dim shps As Collection
    Dim shp As Shape
    
    Set shps = New Collection
    
    Call searchShapesFromPresentation(shps)
    
    For Each shp In shps
        Call searchTextFrame(shp)
    Next
End Sub

Private Sub searchShapesFromPresentation(ByRef shps As Collection)
    Dim sld As Slide
    Dim shp As Shape
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            Call putShapeRecursive(shp, shps)
        Next
    Next
End Sub

Private Sub putShapeRecursive(ByRef shp As Shape, ByRef shps As Collection)
    Dim s As Shape
    If shp.Type <> msoGroup Then
        shps.Add shp
    Else
        For Each s In shp.GroupItems
            Call putShapeRecursive(s, shps)
        Next
    End If
End Sub

Private Sub searchTextFrame(ByRef shp As Shape)
    Dim s As Shape
    
    With shp
        
        ' テキストフレームがあり，テキストがある
        If .HasTextFrame And .TextFrame.HasText Then
            Call checkTextRange(.TextFrame.TextRange)
        ' 表がある
        ElseIf .HasTable Then
            Dim c As Cell
            Dim r As Row
            For Each r In shp.Table.Rows
                For Each c In r.Cells
                    Call searchTextFrame(c.Shape)
                Next
            Next
        End If
        
    End With
End Sub

Private Sub checkTextRange(ByRef range As TextRange)
    With range
        
        ' 一部だけフォントが違ったり，一部だけボールドな場合
        If .Font.Name = "" Or .Font.NameFarEast = "" Or .Font.Bold = msoTriStateMixed Then
            ' 1文字ずつ調べる
            Dim i As Integer
            For i = 1 To .Length
                Call updateFont(.Characters(i, 1).Font)
            Next
        ' すべて同じフォントかつ全体がボールド
        ElseIf .Font.Bold = msoTrue Then
            Call updateFont(.Font)
        End If
        
    End With
End Sub

Private Sub updateFont(ByRef f As Font)
    With f
        
        ' ボールドだったら
        If .Bold Then
            ' 英数字用，日本語用それぞれ別に変更
            If .Name = FROM_FONT Then
                .Name = TO_FONT
            End If
            If .NameFarEast = FROM_FONT Then
                .NameFarEast = TO_FONT
            End If
        End If
        
    End With
End Sub

参考文献

PowerPointのFontをすべて変更するVBA (グループ化されていても!)
https://qiita.com/Umaremin/items/7270a65b72debb17bba2

グループ化と表への対応を参考にさせていただきました．

1. 游ゴシックにはウェイトがLight，Regular，Medium，Boldとあり，PowerPointではRegularの状態で太字にすると自動的にBoldになります．しかし，Light，Mediumの状態で太字にしてもPowerPointが機械的に太くした疑似ボールド体になってしまいます．
   また，Windowsでは游ゴシック(無印)，Light，Mediumしか表示されませんが，無印がRegular，無印を太字にしたときがBoldになっています． ↩