イメージの操作テストで使う

はてなブログとか、
コードを貼り付けると、
色付けされたり、
スペースもそのまま表示される。

まぁ、あたりまえか・・・

---

'使い捨てのマクロ
'パワーポイントのスライド内のフォントを変更する
Sub test20220926pp使い捨てフォントを一括返還()
    
    Dim p As Integer
    Dim strFontName As String  '変更するフォントの名前
    Dim objShape As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか

    '頭でフォントの名前を入れる、使い捨てなのにね・・
    strFontName = InputBox("変更したいフォント名を入力", "入力", "メイリオ")
    If strFontName = "" Then Exit Sub  '↑でキャンセルなら抜ける
    
    '全スライド内のシェイプを上から下まで、いやらしい目でなめまわす(チェックする)
    For p = 1 To ActivePresentation.Slides.Count  'スライド数ループ pページ
        'pページのスライド内のシェイプを探る
        For Each objShape In ActivePresentation.Slides(p).Shapes
            'オブジェクトがテキストを持っているか？チェックしてからセット
            If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
                If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり
                    'ここまで、チェックしたら、フォントの名前変更(フォント変更)
                    objShape.TextFrame.TextRange.Font.NameFarEast = strFontName '入力したフォント名に変更する
                End If
            End If
        Next
    Next
    
    MsgBox "処理終了、フォントを確認して保存してくださいね"

End Sub

---

あと、知恵袋の解答欄って、
コードの頭スペースが無いんだよな
まぁ、これは、貼り付けの使い捨てだからいいのかな。

このコードをパワポの標準モジュールに貼って、
テストしてみてください
と↑、この一言に、いろいろな処理・手順、壁があったり・・・

'使い捨てのマクロ
'パワーポイントのスライド内のフォントを変更する
Sub test20220926pp使い捨てフォントを一括返還()

Dim p As Integer
Dim strFontName As String '変更するフォントの名前
Dim objShape As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか

'頭でフォントの名前を入れる、使い捨てなのにね・・
strFontName = InputBox("変更したいフォント名を入力", "入力", "メイリオ")
If strFontName = "" Then Exit Sub '↑でキャンセルなら抜ける

'全スライド内のシェイプを上から下まで、いやらしい目でなめまわす(チェックする)
For p = 1 To ActivePresentation.Slides.Count 'スライド数ループ pページ
'pページのスライド内のシェイプを探る
For Each objShape In ActivePresentation.Slides(p).Shapes
'オブジェクトがテキストを持っているか？チェックしてからセット
If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり
'ここまで、チェックしたら、フォントの名前変更(フォント変更)
objShape.TextFrame.TextRange.Font.NameFarEast = strFontName '入力したフォント名に変更する
End If
End If
Next
Next

MsgBox "処理終了、フォントを確認して保存してくださいね"

End Sub

'↑ここまでを 1.Alt+F11 か 2.表示 マクロ 作成で作り
'貼り付ける。。