スライドショー中にペンを使うためのボタンマクロ - インストールレスプログラミング( ´ー`)

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

当時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