Powerpoint VBA ActiveXコンボボックスでスライド移動するマクロ
さて,ネタを考える,ということを昨晩やってみて一番最初に思いついたものがこれでした。
2013からは,スライドショー中にピンチアウトすればスライドのサムネイル一覧が見れるので,そういう場合は必要ないものかもしれません。
それ以前で動くのか,確認する術が私にはありませんが,いくつかの項目に関するコード例として作成しました。
①各スライドのタイトルを取得する方法
②コンボボックスのChangeイベントを利用して,スライド移動を実現する方法
③VBEへのアクセス例
これらに取り組んでいます。
各スライドにコンボボックスを入れ,それぞれのChangeイベントにコードを書きこむ必要がありましたので,今回はVBEditorを制御しています。
これを可能にするために,次の設定をお願いします。
また,悪意あるVBAコードに対して危険性が増すことになりますので,くれぐれも自己責任でやるかどうかは考えていただくよう,お願いします。
Powerpoint ファイル→オプション→セキュリティセンター→セキュリティセンターの設定 →
VBA プロジェクト オブジェクト モデルへのアクセスを信頼する にチェック
この設定により,VBEditorをVBAで制御できるようになります。そして,制御される危険性が増します。
さて,本題。次のコードです。
Option Explicit Sub test() Dim SlideTitle As Variant Dim i As Long: i = 1 ReDim SlideTitle(1 To ActivePresentation.Slides.Count) As String Dim TargetSlide As Slide Dim s As Shape, TitleString As String For i = 1 To ActivePresentation.Slides.Count Set TargetSlide = ActivePresentation.Slides(i) If TargetSlide.Shapes.HasTitle = msoTrue Then TitleString = TargetSlide.Shapes.Title.TextFrame.TextRange.Text SlideTitle(i) = Format(TargetSlide.SlideNumber, "00") & TitleString Else SlideTitle(i) = Format(TargetSlide.SlideNumber, "00") End If Next Dim X As Long, Y As Long X = ActivePresentation.SlideMaster.Width - 100 Y = ActivePresentation.SlideMaster.Height - 20 Dim Cmb As Object For Each TargetSlide In ActivePresentation.Slides On Error Resume Next: TargetSlide.Shapes("SlideSelector").Delete: On Error GoTo 0 With TargetSlide.Shapes.AddOLEObject(X, Y, 100, 20, ClassName:="Forms.ComboBox.1") .Name = "SlideSelector" End With Set Cmb = TargetSlide.Shapes("SlideSelector").OLEFormat.Object Cmb.List = SlideTitle Cmb.ListIndex = TargetSlide.SlideIndex - 1 Next Dim code As Object For Each TargetSlide In ActivePresentation.Slides Set code = ActivePresentation.VBProject.VBComponents(TargetSlide.Name).CodeModule On Error Resume Next code.DeleteLines _ code.ProcStartLine("SlideSelector_Change", 0), _ code.ProcCountLines("SlideSelector_Change", 0) On Error GoTo 0 code.AddFromString "Private Sub SlideSelector_Change()" & vbNewLine & vbTab & _ "If SlideShowWindows.Count <> 0 Then" & vbNewLine & vbTab & vbTab & _ "SlideShowWindows(1).View.GotoSlide SlideSelector.ListIndex + 1" & vbNewLine & vbTab & _ "End If" & vbNewLine & _ "End Sub" Next End Sub
いろいろやっている割には短いかもです。
スライドを移動させるわけなので,スライドは数枚用意して,各スライドのタイトルになにか文字を入れておく必要があります。
文字は無いなら無いでもいいですが,移動したかどうかさっぱりなので,入れた方が移動している実感はわきます。
やっている流れとしては,
・全てのスライドのスライド番号とタイトルを取得し,SlideTitleという配列に入れる。
・各スライドにコンボボックスを挿入し,リスト項目を設定。今回はできました。
・各スライドのコンボボックスのコードを書くスライドのクラスモジュールに書き込んでいます。
test を実行すると,
各スライドの右下にスライドを選ぶコンボボックスが作られています。
スライドショーを実行して動くさまを見ていただける・・はず。
ActiveXを挿入して,そのモジュールまで書くという操作は応用が利く話だと思うので,面白かった。
皆様もこのあたりで遊ばれるときは,こまめな保存と履歴を何回かにわけつつひどいダメージを受けないようにご注意をお願いします。
たまにひどい目にあいますから・・(;´▽`A``