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