やりたいこと
PowerPointで、すべてのフォントを一括で変更したい。
オートシェイプや図形、表、グラフなどを想定。
グループ化されていると、処理できなくなるので、グループ内のシェイプを再帰的に探しに行く。
とりあえず、下記のマクロで、テスト環境ではすべてのフォントがMeiryo UIに変更される。
nameFontの内容を、他のフォントに変更すれば、他のフォントへの変更も可能。
Module1
' FontをMeiryo UIに変更する
Public Sub makeFontMeiryoUI()
Const nameFont As String = "Meiryo UI"
Dim col As Collection
Dim shp As Shape
Set col = New Collection
Call getColShapeFromPresentation(col) ' Presentation全体のShapeに対して処理する場合
Call getColShapeFromSlideMaster(col) ' SlideMasterに対しても処理をする場合
For Each shp In col '各Shapeに対して処理
Call changeFont(shp, nameFont) 'Fontを変更する
Next
End Sub
' Fontを変更する
Private Sub changeFont(ByRef shp As Shape, ByVal nameFont As String)
Dim s As Shape
If shp.HasTextFrame Then
Call setFontName(shp.TextFrame.TextRange.Font, nameFont)
ElseIf shp.HasSmartArt Then
For Each s In shp.GroupItems
Call changeFont(s, nameFont)
Next
ElseIf shp.HasTable Then
Dim c As Cell, r As Row
For Each r In shp.Table.Rows
For Each c In r.Cells
Call changeFont(c.Shape, nameFont)
Next
Next
ElseIf shp.HasChart Then
Call setFontName(shp.Chart.Format.TextFrame2.TextRange.Font, nameFont)
For Each s In shp.Chart.Shapes
Call changeFont(s, nameFont)
Next
End If
End Sub
Private Sub setFontName(ByRef f As Object, ByVal nameFont As String)
If TypeName(f) = "Font" Or TypeName(f) = "Font2" Then
f.Name = nameFont
f.NameFarEast = nameFont
f.NameAscii = nameFont
f.NameComplexScript = nameFont
Else
Debug.Print "font type:", TypeName(f)
End If
End Sub
' Presentation全体のShapeに対して処理する場合
Public Sub getColShapeFromPresentation(ByRef col As Collection)
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
Call putShapeIntoCol(shp, col)
Next
Next
End Sub
' 選択されたSlide内のShapeに対して処理する場合
Public Sub getColShapeFromSlide(ByRef col As Collection)
Dim shp As Shape
If ActiveWindow.Selection.Type < ppSelectionSlides Then Exit Sub
For Each shp In ActiveWindow.Selection.SlideRange.Shapes
Call putShapeIntoCol(shp, col)
Next
End Sub
' Group化されている場合も、個別のShapeをcolコレクションに格納
Public Sub putShapeIntoCol(ByRef shp As Shape, ByRef col As Collection)
Dim s As Shape
If shp.Type <> msoGroup Then
col.Add shp
Else
For Each s In shp.GroupItems
Call putShapeIntoCol(s, col)
Next
End If
End Sub
' SlideMasterに対して処理する場合
Public Sub getColShapeFromSlideMaster(ByRef col As Collection)
Dim shp As Shape
Dim d As Design
For Each d In ActivePresentation.Designs
For Each shp In d.SlideMaster.Shapes.Placeholders
Call putShapeIntoCol(shp, col)
Next
Next
End Sub
参考
フォントを一括変更するPowerPointマクロ
https://www.relief.jp/docs/powerpoint-macro-replace-fonts.html
*リンク先のマクロは、グループ化されているときや、表やグラフが含まれているときにうまくフォントが変わらない。