10.VBA PowerPoint文書フォント変更の仕上げ

2019年6月7日 20:11

それでは、いくつかの機能を追加して、ツールとして仕上げましょう。
まず、PowerPointの表テーブルとグラフ内のテキストについてもフォント変更できるようにします。

また、シェイプオブジェクトの種類によって、フォント変更の対象から除外指定できるようにチェックオプションを追加します。

さらに、プログラムの実行ボタンを３つ追加します。
起動中のPPTの表示スライドのみを対象にフォント変更するボタンと、
PPTファイルを開いてフォント変更するボタン、
フォント変更処理を途中で中止するボタンです。

本記事から読み始めた方は、まずは前回までの次の３つの記事の内容を実行しておいてください。
01.新規ブック作成
 03.フォント指定表と起動ボタンの作成
 08.フォント指定の選択リスト化

チェックオプションの追加

チェックオプションのためのチェックボックスを追加していきます。シート上の場所はどこでもよいのですが、２～３行目にある「フォント指定表」のすぐ下にあった方が操作しやすいでしょう。
フォント指定表の選択リストのために配置したフォント名のデータを少し下へずらします。

マウスドラッグで、B5～C10セル領域を選択してから右クリックして、「挿入」を選択します。
そして表示される「セルの挿入」ダイアログで、「下方向にシフト」を選択、［OK］ボタンを押します。

「開発」タブの「挿入」－「チェックボックス（ActiveX コントロール）」を選択します。

シート上の適当な位置をマウスドラッグしてチェックボックスを配置します。そのチェックボックスを選択したまま、右クリックして「プロパティ」を選択します。
「プロパティ」ダイアログで、次の項目の内容を変更します。
(オブジェクト名)：checkPlaceHolder
Caption：プレースホルダーを含む

また、「BackColor」項目のドロップダウンリストから「ボタンの表面」を選択して色を変えて、チェックボックスのコントロールの範囲が目立つようにしておきます。

さらに同様にして、３つのチェックボックスを追加し、「プロパティ」の内容を次のように設定します。

(オブジェクト名)：checkSmartArt
Caption：SmartArtを含む

(オブジェクト名)：checkChart
Caption：グラフを含む

(オブジェクト名)：checkTable
Caption：表テーブルを含む

プログラム実行ボタンの追加

「03.フォント指定表と起動ボタンの作成」の記事を参考にして、シート上の適当な位置に３つのボタンを追加し、「プロパティ」の内容を次のように設定します。

(オブジェクト名)：buttonActiveSlide
Caption：フォント変更 (起動中PPTの表示スライド)

(オブジェクト名)：buttonOpenPresentations
Caption：フォント変更 (PPTファイルを開く)

(オブジェクト名)：buttonAbort
Caption：中止

それでは、次にプログラムコード全体（200行）を示します。
※「VBA PowerPoint文書フォント変更（ツール添付）」にVBAプログラム組込み済で、すぐに実行することができるExcelツールファイルを添付して公開しています。合わせてご覧ください。

プログラムコード全体

Sheetモジュール内のプログラムコード全体を次に示します。これをVBEでSheetモジュールに書き込んでください。
前回までに作成したコードから変更箇所を編集してもよいのですが、変更量が多いので、前回のコードを削除して全てを貼り換えた方がよいと思います。
なお、プログラムの行数が多いので、２つに分けて記載します。

プログラムコード（１／２）

Option Explicit

Private Const RANGE_FONTNAME_ZENKAKU = "B3"
Private Const RANGE_FONTNAME_HANKAKU = "C3"

Private sFontNameZenkaku As String
Private sFontNameHankaku As String
Private sFileNamePage As String
Private nChangeCount As Long
Private bAbortFlag As Boolean

Private Sub buttonPresentation_Click()
    Dim oApplication As Object: Set oApplication = ReadyApplication()
    
    If oApplication.Presentations.Count <> 1 Then
        MsgBox "対象PowerPoint文書を１つだけ開いておいてください"
    Else
        Call ChangeFontPresentation(oApplication.Presentations(1))
        MsgBox "終了!"
    End If
End Sub

Private Sub buttonActiveSlide_Click()
    Dim oApplication As Object: Set oApplication = ReadyApplication()

    If oApplication.Presentations.Count <> 1 Then
        MsgBox "対象PowerPoint文書を１つだけ開いておいてください"
    ElseIf oApplication.Presentations(1).Windows.Count <> 1 Then
        MsgBox "対象文書のウィンドウは１つだけ開いておいてください"
    Else
        Dim oSlide As Object
        Set oSlide = ActiveSlide(oApplication.Presentations(1))
        If oSlide Is Nothing Then
            MsgBox "対象スライドを１つだけ選択しておいてください"
        Else
            Call ChangeFontSlide(oSlide)
            MsgBox "終了!"
        End If
    End If
End Sub

Private Sub buttonOpenPresentations_Click()
    Dim oApplication As Object: Set oApplication = ReadyApplication()
    
    Dim sFileName As Variant
    For Each sFileName In DialogFileName("PowerPoint", "*.ppt?")
        If IsAbort() Then Exit For
        
        Dim oPresentation As Object
        Set oPresentation = oApplication.Presentations.Open(sFileName)
        
        Call ChangeFontPresentation(oPresentation)
        
        If IsAbort() = False Then
            oPresentation.Save
        End If
        
        oPresentation.Close
        Set oPresentation = Nothing
    Next sFileName
    
    If oApplication.Presentations.Count = 0 Then
        oApplication.Quit
        Set oApplication = Nothing
    End If
    
    MsgBox "終了!"
End Sub

Private Sub buttonAbort_Click()
    bAbortFlag = True
End Sub

Private Function IsAbort() As Boolean
    DoEvents
    IsAbort = bAbortFlag
End Function

プログラムコード（２／２）

Private Function ReadyApplication() As Object
    Call StatusBar("準備中...")
    
    sFontNameZenkaku = Range(RANGE_FONTNAME_ZENKAKU)
    sFontNameHankaku = Range(RANGE_FONTNAME_HANKAKU)
    sFileNamePage = ""
    bAbortFlag = False
    
    Set ReadyApplication = CreateObject("PowerPoint.Application")
End Function

Private Function ActiveSlide(oPresentation As Object) As Object
    On Error Resume Next
    Dim nSlideIndex As Long: nSlideIndex = -1
    nSlideIndex = oPresentation.Windows(1).Selection.SlideRange.SlideIndex
    Set ActiveSlide = oPresentation.Slides(nSlideIndex)
End Function

Private Sub ChangeFontPresentation(oPresentation As Object)
    Dim oSlide As Object
    For Each oSlide In oPresentation.Slides
        If IsAbort() Then Exit For
        Call ChangeFontSlide(oSlide)
    Next oSlide
End Sub

Private Sub ChangeFontSlide(oSlide As Object)
    sFileNamePage = oSlide.Parent.Name & " / p." & oSlide.SlideIndex
    Call StatusBar(sFileNamePage)
    nChangeCount = 0
    
    Call ChangeFontShapes(oSlide.Shapes)
End Sub

Private Sub ChangeFontShapes(oShapes As Object)
    Dim oShape As Object
    For Each oShape In oShapes
        If IsAbort() Then Exit For
        Call ChangeFontShape(oShape)
    Next oShape
End Sub

Private Sub ChangeFontShape(oShape As Object)
    If oShape.Type = msoPlaceHolder Then
        If checkPlaceHolder = False Then Exit Sub
    End If
    
    If oShape.Type = msoGroup Then
        Call ChangeFontShapes(oShape.GroupItems)
    ElseIf oShape.Type = msoAutoShape Then
        Call ChangeFont(oShape)
    ElseIf oShape.HasSmartArt Then
        Call ChangeFontSmartArt(oShape)
    ElseIf oShape.HasChart Then
        Call ChangeFontChart(oShape)
    ElseIf oShape.HasTable Then
        Call ChangeFontTable(oShape)
    Else
        Call ChangeFont(oShape)
    End If
End Sub

Private Sub ChangeFontSmartArt(oShape As Object)
    If checkSmartArt = False Then Exit Sub
    
    Call ChangeFontShapes(oShape.GroupItems)
End Sub

Private Sub ChangeFontChart(oShape As Object)
    If checkChart = False Then Exit Sub
    
    Call ChangeFont(oShape.Chart.Format)
End Sub

Private Sub ChangeFontTable(oShape As Object)
    If checkTable = False Then Exit Sub
    
    Dim oRow As Object
    For Each oRow In oShape.Table.Rows
        Dim oCell As Object
        For Each oCell In oRow.Cells
            If IsAbort() Then Exit Sub
            Call ChangeFont(oCell.Shape)
        Next oCell
    Next oRow
End Sub

Private Sub ChangeFont(oShape As Object)
    On Error GoTo ERROR_EXIT
    
    With oShape.TextFrame2.TextRange.Font
        .NameFarEast = sFontNameZenkaku
        .Name = sFontNameHankaku
    End With
    
    nChangeCount = nChangeCount + 1
    Call StatusBar(sFileNamePage & " (" & nChangeCount & ")")
ERROR_EXIT:
End Sub

Private Function DialogFileName(sDescription As String, sExtensions As String) As Collection
    Const DIALOG_CANCEL = 0
    
    Set DialogFileName = New Collection
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add sDescription, sExtensions
        
        If .Show = DIALOG_CANCEL Then Exit Function
        
        Dim sFileName As Variant
        For Each sFileName In .SelectedItems
            DialogFileName.Add sFileName
        Next sFileName
    End With
End Function

Private Sub StatusBar(sMessage As String)
    Application.StatusBar = sMessage
    DoEvents
End Sub

テストページの追加

テスト文書に「タイトルのみ」レイアウトのスライドを１ページ目に追加します。そして、適当なタイトル名、グラフ、表テーブルを追加します。

プログラムの動作確認

チェックオプションを全てチェックして、先ほど追加したテストページのスライドを表示（選択）した状態で、「フォント変更 (起動中PPTの表示スライド)」ボタンを押してプログラムを実行します。
タイトル、グラフ、表テーブルのテキストが、指定フォントに変更され、「終了!」メッセージボックスが表示されたら動作は正常です。「OK」ボタンを押してメッセージボックスを閉じます。

また、チェックオプションで、「プレースホルダーを含む」のチェックを外してプログラムを実行すると、プレースホルダー（このテストページでは、スライドタイトルの部分）を除き、それ以外のテキストのフォントが変更されるようになります。
他のチェックオプションも同様に、チェックすることでフォント変更対象となり、チェックを外すと対象から除外されるようになります。
オプション指定を色々と試してみましょう。

また、「フォント変更 (PPTファイルを開く)」ボタンを押すと、ファイルダイアログが開き、PowerPoint文書ファイルを選択してフォント変更することができます。ファイル選択時にCtrlキーを押しながらファイル名をマウスクリックすることで、複数ファイルを選択することができます。
実行すると、選択した文書ファイルを１つずつ開きながら、フォントを変更してファイルを上書き保存してから閉じます。

プログラムの解説

それでは、プログラムの主な内容を説明しましょう。

モジュール内の変数

前回から、モジュール内の変数を３つ追加しています。
sFileNamePageは、対象の文書ファイル名とフォント変更処理中のスライド番号を格納する変数です。フォント変更処理中にExcelウィンドウのステータスバーにその変数内容を表示します。
nChangeCountは、スライド毎にフォント変更したシェイプオブジェクトの数をカウントします。この内容もステータスバーに表示します。
bAbortFlagは、フォント変更処理の中止要求を示すフラグです。初期値は「False」ですが、「中止」ボタンが押された時に「True」に変更されます。

Private sFileNamePage As String
Private nChangeCount As Long
Private bAbortFlag As Boolean

フォント変更 (起動中PPTの全スライド)

モジュール内の変数の初期化とPowerPointアプリケーションの参照取得の処理をReadyApplication関数に切り出して、「フォント変更 (起動中PPTの表示スライド)」「フォント変更 (PPTファイルを開く)」の処理からも呼び出せるように共通化しています。

Private Sub buttonPresentation_Click()
    Dim oApplication As Object: Set oApplication = ReadyApplication()
    
    ：
    
End Sub

フォント変更 (起動中PPTの表示スライド)

起動中のPowerPoint文書の表示（選択）スライドが１つだけであることを確認した上で、その表示スライドのみをフォント変更します。

Private Sub buttonActiveSlide_Click()
    Dim oApplication As Object: Set oApplication = ReadyApplication()
    
    If oApplication.Presentations.Count <> 1 Then
        MsgBox "対象PowerPoint文書を１つだけ開いておいてください"
    ElseIf oApplication.Presentations(1).Windows.Count <> 1 Then
        MsgBox "対象文書のウィンドウは１つだけ開いておいてください"
    Else
        Dim oSlide As Object
        Set oSlide = ActiveSlide(oApplication.Presentations(1))
        If oSlide Is Nothing Then
            MsgBox "対象スライドを１つだけ選択しておいてください"
        Else
            Call ChangeFontSlide(oSlide)
            MsgBox "終了!"
        End If
    End If
End Sub

フォント変更 (PPTファイルを開く)

ファイルダイアログを開き、選択した文書ファイルのフォントを変更する処理です。

Private Sub buttonOpenPresentations_Click()
    Dim oApplication As Object: Set oApplication = ReadyApplication()
    
    ：
    
End Sub

ファイルダイアログで選択された文書ファイルのファイル名を１つずつ取り出して処理するForループです。なお、「中止」ボタンが押された時には、IsAbort関数の戻り値がTrueとなるのでForループを抜けて処理を中止します。

    Dim sFileName As Variant
    For Each sFileName In DialogFileName("PowerPoint", "*.ppt?")
        If IsAbort() Then Exit For
        
        ：
        
    Next sFileName

ファイル名sFileNameで指定されたPowerPointの文書ファイルを開き、そのフォントを変更します。「中止」ボタンが押されていなければ、その文書ファイルを上書き保存して、閉じます。

        Dim oPresentation As Object
        Set oPresentation = oApplication.Presentations.Open(sFileName)
        
        Call ChangeFontPresentation(oPresentation)
        
        If IsAbort() = False Then
            oPresentation.Save
        End If
        
        oPresentation.Close
        Set oPresentation = Nothing

開いている文書ファイルがなければ、PowerPointアプリケーションを終了します。つまり、本ツールを実行前に開いているPowerPoint文書ファイルがあれば、PowerPointアプリケーションは起動を継続して、アプリケーションを終了しないようにします。

    If oApplication.Presentations.Count = 0 Then
        oApplication.Quit
        Set oApplication = Nothing
    End If

中止ボタン処理

「中止」ボタンが押された時に呼び出され、中止フラグ変数bAbortFlagにTrueを設定します。
IsAbortは、「中止」ボタンが押されたかどうかを返します。Forループ内で検定させて、中止の場合にループを抜けることで処理を中止できます。DoEventsは、OSに制御を移してボタンのクリックイベントを受け取りやすくします。

Private Sub buttonAbort_Click()
    bAbortFlag = True
End Sub

Private Function IsAbort() As Boolean
    DoEvents
    IsAbort = bAbortFlag
End Function

初期化処理

Excelウィンドウのステータスバーに「準備中...」と表示後、モジュール内の変数を初期化します。そして、PowerPointアプリケーションを起動して、そのオブジェクトの参照を戻り値として返します。

Private Function ReadyApplication() As Object
    Call StatusBar("準備中...")
    
    sFontNameZenkaku = Range(RANGE_FONTNAME_ZENKAKU)
    sFontNameHankaku = Range(RANGE_FONTNAME_HANKAKU)
    sFileNamePage = ""
    bAbortFlag = False
    
    Set ReadyApplication = CreateObject("PowerPoint.Application")
End Function

表示スライドの取得

プレゼンテーション文書oPresentationで選択されたスライド番号SlideIndexを取り出し、そのスライドオブジェクトを戻り値として返します。
スライドが選択されていない場合や、複数ページが選択されている場合は、このSlideIndexの参照がエラーとなり、nSlideIndexが-1のままとなるため、スライドオブジェクトの取り出しもエラーとなり、戻り値としてNothingが返ります。

Private Function ActiveSlide(oPresentation As Object) As Object
    On Error Resume Next
    Dim nSlideIndex As Long: nSlideIndex = -1
    nSlideIndex = oPresentation.Windows(1).Selection.SlideRange.SlideIndex
    Set ActiveSlide = oPresentation.Slides(nSlideIndex)
End Function

プレゼンテーション文書のフォント変更

プレゼンテーション文書oPresentationから１枚ずつスライドオブジェクトを取り出し、ChangeFontSlide関数に引数として渡して、フォント変更します。

Private Sub ChangeFontPresentation(oPresentation As Object)
    Dim oSlide As Object
    For Each oSlide In oPresentation.Slides
        If IsAbort() Then Exit For
        Call ChangeFontSlide(oSlide)
    Next oSlide
End Sub

スライドのフォント変更

スライドオブジェクトoSlideから、文書ファイル名とスライド番号を取り出してsFileNamePage変数に格納した上で、Excelウィンドウのステータスバーに表示します。
Parentプロパティにより、スライドオブジェクトの親オブジェクトであるPresentationオブジェクトが参照できるので、そのNameプロパティにより文書ファイル名を取り出すことができます。
スライドオブジェクトのシェイプオブジェクト集合体をChangeFontShapes関数に引数として渡して、フォント変更します。

Private Sub ChangeFontSlide(oSlide As Object)
    sFileNamePage = oSlide.Parent.Name & " / p." & oSlide.SlideIndex
    Call StatusBar(sFileNamePage)
    nChangeCount = 0
    
    Call ChangeFontShapes(oSlide.Shapes)
End Sub

シェイプ集合体のフォント変更

シェイプ集合体oShapesから１枚ずつシェイプオブジェクトを取り出し、ChangeFontShape関数に引数として渡して、フォント変更します。

Private Sub ChangeFontShapes(oShapes As Object)
    Dim oShape As Object
    For Each oShape In oShapes
        If IsAbort() Then Exit For
        Call ChangeFontShape(oShape)
    Next oShape
End Sub

シェイプのフォント変更

シェイプのTypeを確認してプレースホルダーの場合は、「プレースホルダーを含む」オプションを確認して、チェックが外れているFalseの時は、関数処理を終了してフォント変更を行いません。
次にグループ化されたオブジェクトの場合は、そのItemオブジェクトの集合体をさらに分解していきます。
AutoShapeの時はフォント変更します。
また、SmartArtやグラフChart、表Tableの場合は、それぞれ専用の関数を呼び出します。
上記以外Elseの場合は、フォント変更します。例えば単純なTextBoxなどの場合にこの条件に入ってきます。

Private Sub ChangeFontShape(oShape As Object)
    If oShape.Type = msoPlaceHolder Then
        If checkPlaceHolder = False Then Exit Sub
    End If
    
    If oShape.Type = msoGroup Then
        Call ChangeFontShapes(oShape.GroupItems)
    ElseIf oShape.Type = msoAutoShape Then
        Call ChangeFont(oShape)
    ElseIf oShape.HasSmartArt Then
        Call ChangeFontSmartArt(oShape)
    ElseIf oShape.HasChart Then
        Call ChangeFontChart(oShape)
    ElseIf oShape.HasTable Then
        Call ChangeFontTable(oShape)
    Else
        Call ChangeFont(oShape)
    End If
End Sub

SmartArtのフォント変更

「SmartArtを含む」オプションを確認して、チェックが外れているFalseの時は、関数処理を終了してフォント変更を行いません。
「SmartArtを含む」場合は、SmartArtを構成するItemオブジェクト集合体を分解します。

Private Sub ChangeFontSmartArt(oShape As Object)
    If checkSmartArt = False Then Exit Sub
    
    Call ChangeFontShapes(oShape.GroupItems)
End Sub

グラフのフォント変更

「グラフを含む」オプションを確認して、チェックが外れているFalseの時は、関数処理を終了してフォント変更を行いません。
「グラフを含む」場合は、そのグラフのフォントを変更します。

Private Sub ChangeFontChart(oShape As Object)
    If checkChart = False Then Exit Sub
    
    Call ChangeFont(oShape.Chart.Format)
End Sub

表テーブルのフォント変更

「表テーブルを含む」オプションを確認して、チェックが外れているFalseの時は、関数処理を終了してフォント変更を行いません。
「表テーブルを含む」場合は、その表テーブルから各行を取り出し、さらに各行から各セルを取り出して、その各セルのフォントを変更します。

Private Sub ChangeFontTable(oShape As Object)
    If checkTable = False Then Exit Sub
    
    Dim oRow As Object
    For Each oRow In oShape.Table.Rows
        Dim oCell As Object
        For Each oCell In oRow.Cells
            If IsAbort() Then Exit Sub
            Call ChangeFont(oCell.Shape)
        Next oCell
    Next oRow
End Sub

フォント変更

引数で指定されたシェイプオブジェクトについて、全角文字用と半角文字用用のフォントを設定変更します。そして、スライドごとにフォント変更したシェイプオブジェクトの数をファイル名とスライド番号とともにExcelウィンドウのステータスバーに表示します。

Private Sub ChangeFont(oShape As Object)
    On Error GoTo ERROR_EXIT
    
    With oShape.TextFrame2.TextRange.Font
        .NameFarEast = sFontNameZenkaku
        .Name = sFontNameHankaku
    End With
    
    nChangeCount = nChangeCount + 1
    Call StatusBar(sFileNamePage & " (" & nChangeCount & ")")
ERROR_EXIT:
End Sub

ファイルダイアログ処理

ファイルダイアログを表示して、選択されたファイル名をCollection戻り値として返します。.AllowMultiSelect = Trueとすることで複数ファイル選択が可能となります。

Private Function DialogFileName(sDescription As String, sExtensions As String) As Collection
    Const DIALOG_CANCEL = 0
    
    Set DialogFileName = New Collection
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add sDescription, sExtensions
        
        If .Show = DIALOG_CANCEL Then Exit Function
        
        Dim sFileName As Variant
        For Each sFileName In .SelectedItems
            DialogFileName.Add sFileName
        Next sFileName
    End With
End Function

ステータスバー表示

指定メッセージをExcelウィンドウのステータスバーに表示します。

Private Sub StatusBar(sMessage As String)
    Application.StatusBar = sMessage
    DoEvents
End Sub

さいごに

これで、PowerPoint文書フォント変更のツールはひとまず完成です。
最後までお読みいただきありがとうございました。
お気づきの点などありましたらコメント頂けますと幸いです。

いいなと思ったら応援しよう！

記事を気に入って頂き、お役に立てたら嬉しいです。