パワーポイント２０１３ ファイル名自動表示方法

質問

パワーポイントの全スライドのフッタの左に印刷日時、中央に頁番号／全ページ数、右下にファイル名を指定のフォントとサイズ（ポイント）で自動挿入する方法（ＶＢＡコード）をご教示下さい 。フッタの位置を手動で変更できれば嬉しい。

回答No.1

HohoPapa

パワーポイントでVBAを扱ったことがないので
勉強を兼ねて挑戦してみました。

>印刷日時
印刷をするマクロではないので、マクロの実行日時としました。

>フッタの位置を手動で変更できれば
この求めがよくわかりません。
そもそもパワーポイントですので、移動は自由です。

パワーポイントが用意しているフッターを使うと
いろいろ厄介なので
自前でテキストボックスを追加する仕様としました。

また、
追加と諸々の設定（編集）を１つのプロシージャで行うと
編集が期待通りになっていない場合
追加したテキストボックスを削除する必要があるので、
追加と編集を別にしました。

つまり、追加は1回だけ行い、
編集は何度でもやり直せる仕様としました。

'//------------------------------------------------------------------------------------------------
'//　オリジナルフッター作成
'//------------------------------------------------------------------------------------------------
Sub MakeMyFooter()
　Dim SlideCount As Long　'総スライド数
　Dim SlideCounter As Long 'Slideカウンター
　Dim txt As Shape
　Const FootFontSize = 20
　Const FootTop = 500
　Const Foot1Height = 30
　Const Foot1Width = 250
　Const Foot1Left = 10
　Const Foot2Height = 30
　Const Foot2Width = 60
　Const Foot2Left = 310
　Const Foot3Height = 30
　Const Foot3Width = 300
　Const Foot3Left = 510

　'総スライド数算出
　SlideCount = ActivePresentation.Slides.Count

　'Footer1,2,3を追加
　With ActivePresentation
　　For SlideCounter = 1 To SlideCount

　　　Set txt = .Slides(SlideCounter).Shapes.AddTextbox( _
　　　　Orientation:=msoTextOrientationHorizontal, _
　　　　Left:=Foot1Left, _
　　　　Top:=FootTop, _
　　　　Width:=Foot1Width, _
　　　　Height:=Foot1Height)

　　　With txt
　　　　.Name = "Foot1"
　　　　.TextFrame.TextRange = "Foot1"
　　　　.TextEffect.FontSize = FootFontSize
　　　End With

　　　Set txt = .Slides(SlideCounter).Shapes.AddTextbox( _
　　　　Orientation:=msoTextOrientationHorizontal, _
　　　　Left:=Foot2Left, _
　　　　Top:=FootTop, _
　　　　Width:=Foot2Width, _
　　　　Height:=Foot2Height)

　　　With txt
　　　　.Name = "Foot2"
　　　　.TextFrame.TextRange = "Foot2"
　　　　.TextEffect.FontSize = FootFontSize
　　　End With

　　　Set txt = .Slides(SlideCounter).Shapes.AddTextbox( _
　　　　Orientation:=msoTextOrientationHorizontal, _
　　　　Left:=Foot3Left, _
　　　　Top:=FootTop, _
　　　　Width:=Foot3Width, _
　　　　Height:=Foot3Height)

　　　With txt
　　　　.Name = "Foot3"
　　　　.TextFrame.TextRange = "Foot3"
　　　　.TextEffect.FontSize = FootFontSize
　　　End With

　　Next SlideCounter
　End With

End Sub

'//------------------------------------------------------------------------------------------------
'//　オリジナルフッター編集
'//------------------------------------------------------------------------------------------------
Sub ChangeMyFooter()
　Dim SlideCount As Long　'総スライド数
　Dim SlideCounter As Long 'Slideカウンター
　Dim txt As Shape

　'Const FootFont = "HGP創英角ポップ体"
　Const FootFont = "ＭＳ 明朝"
　Const FootFontSize = 12
　Const FootTop = 450
　Const Foot1Height = 30
　Const Foot1Width = 250
　Const Foot1Left = 10
　Const Foot2Height = 30
　Const Foot2Width = 60
　Const Foot2Left = 310
　Const Foot3Height = 30
　Const Foot3Width = 300
　Const Foot3Left = 510

　'総スライド数算出
　SlideCount = ActivePresentation.Slides.Count

　'Footer1,2,3を編集
　With ActivePresentation
　　For SlideCounter = 1 To SlideCount
　　　With .Slides(SlideCounter).Shapes("Foot1")
　　　　.Height = Foot1Height
　　　　.Width = Foot1Width
　　　　.Left = Foot1Left
　　　　.Top = FootTop
　　　　.TextFrame.TextRange.Text = Format(Now, "YYYY/MM/DD HH:MM")
　　　　.TextEffect.FontSize = FootFontSize
　　　　.TextEffect.FontName = FootFont
　　　End With

　　　With .Slides(SlideCounter).Shapes("Foot2")
　　　　.Height = Foot2Height
　　　　.Width = Foot2Width
　　　　.Left = Foot2Left
　　　　.Top = FootTop
　　　　.TextFrame.TextRange.Text = Format(SlideCounter, "0") & "/" & Format(SlideCount, "0")
　　　　.TextEffect.FontSize = FootFontSize
　　　　.TextEffect.FontName = FootFont
　　　End With

　　　With .Slides(SlideCounter).Shapes("Foot3")
　　　　.Height = Foot3Height
　　　　.Width = Foot3Width
　　　　.Left = Foot3Left
　　　　.Top = FootTop
　　　　.TextFrame.TextRange.Text = ActivePresentation.Name
　　　　.TextEffect.FontSize = FootFontSize
　　　　.TextEffect.FontName = FootFont
　　　End With
　　Next SlideCounter
　End With

End Sub

お礼

ありがとうございます。試してみます。