Powerpoint VBAを使おう!

Powerpoint VBAやExcelのVBAで遊んでいます。AdobeのScriptにも興味が少し。。

スライドショー中にペンを使うためのボタンマクロ

パワーポイントでマクロを組み始めるきっかけになった,職場の後輩から教えてもらったボタンのことを不意に思い出しました。

当時OneNoteがまだまだ,仕様不明な状態で,それでも書き込みをできる環境を,とパワーポイントで電子黒板と向かったときのことです。

でも,ボタンをいちいちコピーするの面倒だなぁと思い,結局あまり使うことが無かったのですが,

その仕組みはいいものだよなぁと今でも思い出せるので,ボタンを作るマクロをばたばたと作ってみました。個人的に懐かしいものです。(゚▽゚*)

Const Xsize = 10
Const Ysize = 10

Sub 各スライドにボタン設置()
    ActivePresentation.SlideShowSettings.Run.View.PointerType = ppSlideShowPointerArrow
    Dim s As Slide, i As Long
    On Error Resume Next
    For Each s In ActivePresentation.Slides
        For i = 1 To 7
            s.Shapes("DrawPointer" & i).Delete
        Next
        ボタン設置 (s.SlideIndex)
    Next
    On Error GoTo 0
End Sub

Sub ボタン設置(SlideIndex As Long)
    
    Dim xpos As Long, ypos As Long, 補正 As Long
    With ActivePresentation.SlideMaster
        xpos = .Width - Xsize * 9
        ypos = .Height - Ysize
    End With
    
    補正 = 0
    
    With ActivePresentation.Slides(SlideIndex).Shapes.AddShape(msoShapeRectangle, xpos + 補正, ypos, Xsize, Ysize)
        .Name = "DrawPointer1"
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "消しモード"
        .ActionSettings(ppMouseOver).Action = ppActionRunMacro
        .ActionSettings(ppMouseOver).Run = "ポインタ"
        .TextFrame.TextRange.Text = "E"
        .TextFrame.TextRange.Font.Size = 6
        .TextFrame.TextRange.Font.Color.RGB = rgbBlack
        補正 = 補正 + Xsize
    End With
    
    With ActivePresentation.Slides(SlideIndex).Shapes.AddShape(msoShapeRectangle, xpos + 補正, ypos, Xsize, Ysize)
        .Name = "DrawPointer2"
        .Fill.ForeColor.RGB = RGB(0, 0, 0)
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "描画1"
        .ActionSettings(ppMouseOver).Action = ppActionRunMacro
        .ActionSettings(ppMouseOver).Run = "ポインタ"
        補正 = 補正 + Xsize
    End With
    
    With ActivePresentation.Slides(SlideIndex).Shapes.AddShape(msoShapeRectangle, xpos + 補正, ypos, Xsize, Ysize)
        .Name = "DrawPointer3"
        .Fill.ForeColor.RGB = RGB(255, 0, 0)
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "描画2"
        .ActionSettings(ppMouseOver).Action = ppActionRunMacro
        .ActionSettings(ppMouseOver).Run = "ポインタ"
        補正 = 補正 + Xsize
    End With
            
    With ActivePresentation.Slides(SlideIndex).Shapes.AddShape(msoShapeRectangle, xpos + 補正, ypos, Xsize, Ysize)
        .Name = "DrawPointer4"
        .Fill.ForeColor.RGB = RGB(0, 255, 0)
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "描画3"
        .ActionSettings(ppMouseOver).Action = ppActionRunMacro
        .ActionSettings(ppMouseOver).Run = "ポインタ"
        補正 = 補正 + Xsize
    End With

    With ActivePresentation.Slides(SlideIndex).Shapes.AddShape(msoShapeRectangle, xpos + 補正, ypos, Xsize, Ysize)
        .Name = "DrawPointer5"
        .Fill.ForeColor.RGB = RGB(0, 0, 255)
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "描画4"
        .ActionSettings(ppMouseOver).Action = ppActionRunMacro
        .ActionSettings(ppMouseOver).Run = "ポインタ"
        補正 = 補正 + Xsize
    End With
        
    With ActivePresentation.Slides(SlideIndex).Shapes.AddShape(msoShapeRectangle, xpos + 補正, ypos, Xsize, Ysize)
        .Name = "DrawPointer6"
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "描画5"
        .ActionSettings(ppMouseOver).Action = ppActionRunMacro
        .ActionSettings(ppMouseOver).Run = "ポインタ"
        補正 = 補正 + Xsize
    End With
        
    With ActivePresentation.Slides(SlideIndex).Shapes.AddShape(msoShapeRectangle, xpos + 補正, ypos, Xsize, Ysize)
        .Name = "DrawPointer7"
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "ポインタ"
        .ActionSettings(ppMouseOver).Action = ppActionRunMacro
        .ActionSettings(ppMouseOver).Run = "ポインタ"
        .TextFrame.TextRange.Text = "P"
        .TextFrame.TextRange.Font.Size = 6
        .TextFrame.TextRange.Font.Color.RGB = rgbBlack
        補正 = 補正 + Xsize
    End With
        
    With ActivePresentation.Slides(SlideIndex).Shapes.AddShape(msoShapeRectangle, xpos + 補正, ypos, Xsize, Ysize)
        .Name = "DrawPointer8"
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .ActionSettings(ppMouseClick).Action = ppActionPreviousSlide
        .ActionSettings(ppMouseOver).Action = ppActionRunMacro
        .ActionSettings(ppMouseOver).Run = "ポインタ"
        .TextFrame.TextRange.Text = "←"
        .TextFrame.TextRange.Font.Size = 6
        .TextFrame.TextRange.Font.Color.RGB = rgbBlack
        補正 = 補正 + Xsize
    End With
    
    With ActivePresentation.Slides(SlideIndex).Shapes.AddShape(msoShapeRectangle, xpos + 補正, ypos, Xsize, Ysize)
        .Name = "DrawPointer9"
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .ActionSettings(ppMouseClick).Action = ppActionNextSlide
        .ActionSettings(ppMouseOver).Action = ppActionRunMacro
        .ActionSettings(ppMouseOver).Run = "ポインタ"
        .TextFrame.TextRange.Text = "→"
        .TextFrame.TextRange.Font.Size = 6
        .TextFrame.TextRange.Font.Color.RGB = rgbBlack
    End With

End Sub


Sub 描画モード(1 As Long,2 As Long,3 As Long)
    With ActivePresentation.SlideShowSettings.Run.View
        .PointerColor.RGB = RGB(1,2,3)
        .PointerType = ppSlideShowPointerPen
    End With
End Sub

Sub ポインタ()
     ActivePresentation.SlideShowSettings.Run.View.PointerType = ppSlideShowPointerArrow
End Sub

Sub 消しモード()
     ActivePresentation.SlideShowSettings.Run.View.PointerType = ppSlideShowPointerEraser
End Sub

Sub 描画1()
    Call 描画モード(0, 0, 0)
End Sub

Sub 描画2()
    Call 描画モード(255, 0, 0)
End Sub
Sub 描画3()
    Call 描画モード(0, 255, 0)
End Sub
Sub 描画4()
    Call 描画モード(0, 0, 255)
End Sub
Sub 描画5()
    Call 描画モード(255, 255, 255)
End Sub

適当に作ったので,あまり細かいことは考えていませんが,

  各スライドにボタン設置

を実行すると,その時あるすべてのスライドの右下にちっちゃいボタンをたくさん作ります。

f:id:chemiphys:20180911223844p:plain

E は消しゴム
色 はその色のペンになる
P はポインタに戻すためのボタンだったんですが,いちいちそれ触らないと色を変えれなかったので,ボタン群の上を通るとポインタに勝手に戻ります。
←→はスライドの移動です。

コード見ればすごい単純なので,必要な数のボタンを必要な大きさで作れば役に立つ層もあるかもしれません。

MouseOverでポインタに勝手に戻るのがむしろ面倒な場合はその部分をコメントアウトしてもらえれば。。

最初これは クラスモジュールで作り始めてみてたんですが,ActionSettingからクラスモジュール内のメソッド等にアクセスできる気がしなかったので,

標準モジュール上で遊んで終わることになりました。

きちんと作ればFor Nextと配列でスマートに作れるんでしょうけど,気分で作ったのでコピペ全開です( ´ー`)