ペンを全て消す

概要
コード

概要

ActivePresentation のペンを一括で消したかったので作りました。

.Type = msoInkComment 判定しているとおり、該当すれば消えます。
msoInkComment は MsoShapeType という図形を表す定数です。
（ペンはグループ化されてしまうことがあり、そうなるとtypeがgroupになってしまうため、本処理の前にグループ解除が必要です）

コード

Sub EraseInk()
    
    '------------------------------------------------------------------------------
    ' ペンを消す
    ' ※ペンは自動でグループ化されてしまうことがある。その場合は本処理の前にグループ解除が必要
    '------------------------------------------------------------------------------
    
    Dim pptPrs As Variant       'ActivePresentation
    Dim p As Long               'スライド用変数
    Dim intShape As Long        'Shapeの番号
    Dim lngFirstSlideNo As Long '開始スライド
    
    'ActivePresentation
    Set pptPrs = ActivePresentation
    
    '開始スライド番号
    If pptPrs.PageSetup.FirstSlideNumber = 0 Then
        lngFirstSlideNo = 1
    Else
        lngFirstSlideNo = pptPrs.PageSetup.FirstSlideNumber
    End If
    
    '全スライドのペンを削除
    For p = lngFirstSlideNo To pptPrs.Slides.Count
        With ActivePresentation.Slides(p).Shapes    'pは1からのみ指定可
            For intShape = .Count To 1 Step -1
                With .Item(intShape)
                    Debug.Print .Type &amp; .Name
                    If .Type = msoInkComment Then   'msoInkComment(23) インク コメント
                        .Delete                     '削除
                    End If
                End With
            Next intShape
        End With
    Next p
    
End Sub