PowerPointのスライドにキャプションを置く

PowerPointVBA VBAクラス・モジュール

PowerPointのスライドにキャプションを置くクラス

PowerPoint初心者です。仕事でもほとんど使う機会がなかったので、そこらへんの素人以下です。

スライドショー的なPresentation

そんなPowerPointど素人の私が、画像中心のPresentationを作ることになった。

百枚近くある写真を次々に見せていくだけのもの。

そもそもPowerPointでやるのがふさわしいのかどうかもよくわからん。その程度にはIT音痴の私。

写真を貼り付けるのはマクロで瞬殺したものの、キャプションを入れるのがめんどくさい……。

そこで、PowerPointVBA入門を兼ねて、スライドにキャプションを入れるマクロを作った。

キャプション的なものを入れるのは、今後も使い回せそう……しかしながら、フォントとかマージンとか寸法とか位置決めとか、設定項目がやたらたくさんあるので、クラスにしておいたら便利ではないかと思った。

望ましいソリューションなのかは初心者ゆえわかりませんが。

CaptionBoxクラス

とりあえず、クラスモジュールを晒しておこう。

リスト１　クラスモジュール CaptionBox
Option Explicit

Private captBox_ As PowerPoint.Shape
Private txtFrame_ As PowerPoint.TextFrame

Public Property Get Self() As PowerPoint.Shape
  Set Self = captBox_
End Property

Public Property Get TextFrame() As PowerPoint.TextFrame
  Set TextFrame = txtFrame_
End Property

Public Sub init(ByVal targetSlide As Slide, _
                ByVal targetText As String)
  Dim Sld As Slide
  Set Sld = targetSlide
  Const DEFAULT_TOP As Single = 10
  Const DEFAULT_LEFT As Single = 10
  Const DEFAULT_HEIGHT As Single = 45
  Const DEFAULT_BOXCOLOR As Long = vbRed
  Const DEFAULT_FONTSIZE As Single = 28
  Const DEFAULT_FONTNAME As String = "游ゴシック"
  Const DEFAULT_FONTFAREAST As String = "游ゴシック"
  Const DEFAULT_MARGINTOP As Single = 0.2
  Const DEFAULT_MARGINBOTTOM As Single = 0.1
  Const DEFAULT_FONTCOLOR As Long = vbWhite
  'スライドマスターのサイズに合わせてテキストボックス幅を決める'
  Dim captWidth As Single
  captWidth = Sld.Master.Width - (DEFAULT_LEFT * 2)
  'テキストボックスを追加'
  Set captBox_ = targetSlide.Shapes.AddTextbox( _
                                      msoTextOrientationHorizontal, _
                                      DEFAULT_LEFT, DEFAULT_TOP, _
                                      captWidth, DEFAULT_HEIGHT)
  'ボックスを塗りつぶす'
  captBox_.Fill.ForeColor.RGB = DEFAULT_BOXCOLOR
  'Module Level変数txtFrame_にTextFrameオブジェクトをセット'
  Set txtFrame_ = captBox_.TextFrame
  'テキストまわりをセット'
  With txtFrame_
    'ボックス内の上下マージン調整'
    .MarginTop = convertCentimetersToPoints(DEFAULT_MARGINTOP)
    .MarginBottom = convertCentimetersToPoints(DEFAULT_MARGINBOTTOM)
    With .TextRange
      'テキストをセット'
      .Text = targetText
      'フォントまわりの調整'
      With .Font
        .Name = DEFAULT_FONTNAME
        .NameFarEast = DEFAULT_FONTFAREAST
        .Size = DEFAULT_FONTSIZE
        .Color = DEFAULT_FONTCOLOR
      End With
    End With
  End With
End Sub

'///センチメートルをポイントに換算する'
Private Function convertCentimetersToPoints( _
                   ByVal valueByCm As Single) As Single
  Const CONV_RATIO As Single = 28.34646 '1センチは28.34646ポイント'
  Dim ret As Single
  ret = valueByCm * CONV_RATIO
  convertCentimetersToPoints = ret
End Function

'///Selectメソッド'
Public Sub selectMyself()
  Call captBox_.Select
End Sub

'///動かす'
Public Sub moveTo( _
             Optional ByVal moveUp As Single, _
             Optional ByVal moveDown As Single, _
             Optional ByVal moveToLeft As Single, _
             Optional ByVal moveToRight As Single)
  With captBox_
    .Top = .Top - moveUp
    .Top = .Top + moveDown
    .Left = .Left - moveToLeft
    .Left = .Left + moveToRight
  End With
End Sub

'///上下位置を反転させる'
Public Sub flipHorizontally()
  Dim topPos As Single
  topPos = captBox_.Parent.Master.Height - (captBox_.Top + captBox_.Height)
  captBox_.Top = topPos
End Sub

相変わらずのタテ長ですまぬ。

とりあえず、インスタンス生成後、キャプションを置きたいSlideオブジェクトと、キャプションの文字列を渡してinitメソッドを実行すると、指定したスライドにキャプション用のテキストボックスが設置される。

デフォルトでは、

  • 両サイドに10ポイントのマージン
  • テキストボックスの幅は両サイドから10ポイントづつオフセットしたサイズ
  • 上マージンは10ポイント
  • タテの寸法は45ポイント
  • フォントは游ゴシック
  • フォントサイズは28ポイント
  • テキストの上マージンは0.2センチ
  • 同下マージンは0.1センチ
  • ボックスは赤で塗りつぶし
  • フォント色は白

とまあ、こんな感じ。テキストの上マージンを大きくしているのは、游ゴシックのフォント高が上下アンバランスなため。メイリオだったらもっとアンバランスなので、もっと極端にする必要があると思う。実験はしていない。

プロパティは、SelfとTextFrameの二つだけ。

Selfは自身（つまり、Shapeオブジェクト）を表す。ホントはデフォルトプロパティにしたいんだけれど、オブジェクト型のデフォルトプロパティは設定できないみたいなので、こんなぶさいくな形にせざるを得なかった。

もう一つのTextFrameは文字通りTextFrameオブジェクト。テキストボックスをあれこれいじくるときに、一番よく使うのがShape.TextFrameオブジェクトなので、こいつだけ直接アクセスできるようにした。うまいやり方なのかどうかはわからん。

次にメソッド。

今のところ、とりあえずselectMyselfメソッド、moveToメソッドとflipHorizontallyメソッドの三つ。

selectMyselfは、Shape.Selectをラップしただけ。このクラスの仕様上、[CaptionBox].Self.Selectとも書けてしまうところがイマイチ。

moveToメソッドは、文字通りテキストボックスの位置をポイント単位で動かす。

あと、flipHorizontallyメソッドは、テキストボックスの上下位置を反転させる。

かなり大雑把な設計だけれど、まあこのぐらいあれば実用には困らないかな、という感じ。

使ってみる

f:id:akashi_keirin:20190907225139j:plain

こんなふうに、２～４枚目のスライドに画像が貼り付いているとする。

この２～４枚目にキャプションを付けよう、という算段。

リスト２　標準モジュール
Public Sub addCaptionMain()
  Dim Slds As PowerPoint.Slides
  Set Slds = ActivePresentation.Slides
  
  Const TSURUGA_PAKEN As String = _
        "敦賀ヨーロッパ軒（１） " & _
        "敦賀ヨーロッパ軒（２） " & _
        "敦賀ヨーロッパ軒（３）"
  Dim ar() As String
  ar = Split(TSURUGA_PAKEN)

  Dim i As Long
  Dim captBox As CaptionBox
  For i = LBound(ar) To UBound(ar)
    Set captBox = insertCaption(Slds(i + 2), ar(i), True)
    With captBox
      With .Self
        .Fill.ForeColor.RGB = vbBlack
        .Fill.Transparency = 0.4
      End With
      .TextFrame.HorizontalAnchor = msoAnchorCenter
    End With
  Next
End Sub

Private Function insertCaption( _
            ByVal targetSlide As PowerPoint.Slide, _
            ByVal captString As String, _
   Optional ByVal isBottom As Boolean = False) As CaptionBox
  Dim ret As CaptionBox
  Set ret = New CaptionBox
  Call ret.init(targetSlide, captString)
  If isBottom Then Call ret.flipHorizontally
  Set insertCaption = ret
End Function

あくまでも実験なので、「敦賀ヨーロッパ軒（１）」～「敦賀ヨーロッパ軒（３）」までの三つの要素を持つ配列を用意して、３枚の画像にそれぞれキャプションを付けることにする。

何十枚も画像があるときは、別途テキストファイルなどでキャプション文字列群を用意すれば良い。

今回は、３枚の画像の下方に順番にキャプションをセットし、塗りつぶし色は黒、透過性を40%にして、テキストは中央揃えにした。

実行結果

f:id:akashi_keirin:20190907225144j:plain

f:id:akashi_keirin:20190907225147j:plain

f:id:akashi_keirin:20190907225152j:plain

こんな感じ。

おわりに

この程度のことができただけでも、結構うれしい。