![帯](https://assets.st-note.com/production/uploads/images/12135080/rectangle_large_type_2_56db1a7889662226c4beecdc70abeb37.png?width=1200)
10.VBA PowerPoint文書フォント変更の仕上げ
それでは、いくつかの機能を追加して、ツールとして仕上げましょう。
まず、PowerPointの表テーブルとグラフ内のテキストについてもフォント変更できるようにします。
また、シェイプオブジェクトの種類によって、フォント変更の対象から除外指定できるようにチェックオプションを追加します。
さらに、プログラムの実行ボタンを3つ追加します。
起動中のPPTの表示スライドのみを対象にフォント変更するボタンと、
PPTファイルを開いてフォント変更するボタン、
フォント変更処理を途中で中止するボタンです。
本記事から読み始めた方は、まずは前回までの次の3つの記事の内容を実行しておいてください。
01.新規ブック作成
03.フォント指定表と起動ボタンの作成
08.フォント指定の選択リスト化
チェックオプションの追加
チェックオプションのためのチェックボックスを追加していきます。シート上の場所はどこでもよいのですが、2~3行目にある「フォント指定表」のすぐ下にあった方が操作しやすいでしょう。
フォント指定表の選択リストのために配置したフォント名のデータを少し下へずらします。
マウスドラッグで、B5~C10セル領域を選択してから右クリックして、「挿入」を選択します。
そして表示される「セルの挿入」ダイアログで、「下方向にシフト」を選択、[OK]ボタンを押します。
「開発」タブの「挿入」-「チェックボックス(ActiveX コントロール)」を選択します。
シート上の適当な位置をマウスドラッグしてチェックボックスを配置します。そのチェックボックスを選択したまま、右クリックして「プロパティ」を選択します。
「プロパティ」ダイアログで、次の項目の内容を変更します。
(オブジェクト名):checkPlaceHolder
Caption:プレースホルダーを含む
また、「BackColor」項目のドロップダウンリストから「ボタンの表面」を選択して色を変えて、チェックボックスのコントロールの範囲が目立つようにしておきます。
さらに同様にして、3つのチェックボックスを追加し、「プロパティ」の内容を次のように設定します。
(オブジェクト名):checkSmartArt
Caption:SmartArtを含む
(オブジェクト名):checkChart
Caption:グラフを含む
(オブジェクト名):checkTable
Caption:表テーブルを含む
プログラム実行ボタンの追加
「03.フォント指定表と起動ボタンの作成」の記事を参考にして、シート上の適当な位置に3つのボタンを追加し、「プロパティ」の内容を次のように設定します。
(オブジェクト名):buttonActiveSlide
Caption:フォント変更 (起動中PPTの表示スライド)
(オブジェクト名):buttonOpenPresentations
Caption:フォント変更 (PPTファイルを開く)
(オブジェクト名):buttonAbort
Caption:中止
それでは、次にプログラムコード全体(200行)を示します。
※「VBA PowerPoint文書フォント変更(ツール添付)」にVBAプログラム組込み済で、すぐに実行することができるExcelツールファイルを添付して公開しています。合わせてご覧ください。
プログラムコード全体
Sheetモジュール内のプログラムコード全体を次に示します。これをVBEでSheetモジュールに書き込んでください。
前回までに作成したコードから変更箇所を編集してもよいのですが、変更量が多いので、前回のコードを削除して全てを貼り換えた方がよいと思います。
なお、プログラムの行数が多いので、2つに分けて記載します。
プログラムコード(1/2)
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文書を1つだけ開いておいてください"
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文書を1つだけ開いておいてください"
ElseIf oApplication.Presentations(1).Windows.Count <> 1 Then
MsgBox "対象文書のウィンドウは1つだけ開いておいてください"
Else
Dim oSlide As Object
Set oSlide = ActiveSlide(oApplication.Presentations(1))
If oSlide Is Nothing Then
MsgBox "対象スライドを1つだけ選択しておいてください"
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
プログラムコード(2/2)
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
テストページの追加
テスト文書に「タイトルのみ」レイアウトのスライドを1ページ目に追加します。そして、適当なタイトル名、グラフ、表テーブルを追加します。
プログラムの動作確認
チェックオプションを全てチェックして、先ほど追加したテストページのスライドを表示(選択)した状態で、「フォント変更 (起動中PPTの表示スライド)」ボタンを押してプログラムを実行します。
タイトル、グラフ、表テーブルのテキストが、指定フォントに変更され、「終了!」メッセージボックスが表示されたら動作は正常です。「OK」ボタンを押してメッセージボックスを閉じます。
また、チェックオプションで、「プレースホルダーを含む」のチェックを外してプログラムを実行すると、プレースホルダー(このテストページでは、スライドタイトルの部分)を除き、それ以外のテキストのフォントが変更されるようになります。
他のチェックオプションも同様に、チェックすることでフォント変更対象となり、チェックを外すと対象から除外されるようになります。
オプション指定を色々と試してみましょう。
また、「フォント変更 (PPTファイルを開く)」ボタンを押すと、ファイルダイアログが開き、PowerPoint文書ファイルを選択してフォント変更することができます。ファイル選択時にCtrlキーを押しながらファイル名をマウスクリックすることで、複数ファイルを選択することができます。
実行すると、選択した文書ファイルを1つずつ開きながら、フォントを変更してファイルを上書き保存してから閉じます。
プログラムの解説
それでは、プログラムの主な内容を説明しましょう。
モジュール内の変数
前回から、モジュール内の変数を3つ追加しています。
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文書の表示(選択)スライドが1つだけであることを確認した上で、その表示スライドのみをフォント変更します。
Private Sub buttonActiveSlide_Click()
Dim oApplication As Object: Set oApplication = ReadyApplication()
If oApplication.Presentations.Count <> 1 Then
MsgBox "対象PowerPoint文書を1つだけ開いておいてください"
ElseIf oApplication.Presentations(1).Windows.Count <> 1 Then
MsgBox "対象文書のウィンドウは1つだけ開いておいてください"
Else
Dim oSlide As Object
Set oSlide = ActiveSlide(oApplication.Presentations(1))
If oSlide Is Nothing Then
MsgBox "対象スライドを1つだけ選択しておいてください"
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
ファイルダイアログで選択された文書ファイルのファイル名を1つずつ取り出して処理する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から1枚ずつスライドオブジェクトを取り出し、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から1枚ずつシェイプオブジェクトを取り出し、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文書フォント変更のツールはひとまず完成です。
最後までお読みいただきありがとうございました。
お気づきの点などありましたらコメント頂けますと幸いです。
記事を気に入って頂き、お役に立てたら嬉しいです。