Option Explicit

'====================================================
' ブックを開いたときに不要な図形を自動削除する
'
' ■概要
'   ・Workbookを開くと自動実行
'   ・指定した名前の図形だけ残す
'   ・それ以外の図形を削除
'
' ■用途
'   ・テンプレート初期化
'   ・不要画像の削除
'   ・印刷用レイアウトの維持
'   ・利用者が貼り付けた画像のリセット
'
'====================================================

Private Sub Workbook_Open()

    Dim ws As Worksheet
    Dim shp As Shape
    Dim i As Long

    '==========================
    '残す図形名を設定
    '==========================
    Dim KeepList As Variant

    KeepList = Array( _
        "Picture 1", _
        "Picture 2" _
    )

    '==========================
    '全シートを処理
    '==========================
    For Each ws In ThisWorkbook.Worksheets

        '削除しながらループするため後ろから処理
        For i = ws.Shapes.Count To 1 Step -1

            Set shp = ws.Shapes(i)

            If Not IsKeepShape(shp.Name, KeepList) Then
                shp.Delete
            End If

        Next i

    Next ws

End Sub

'====================================================
' 指定した図形名かどうか判定する関数
'
' 引数
'   ShapeName  ：図形名
'   KeepList   ：残す図形一覧
'
' 戻り値
'   True ＝残す
'   False＝削除対象
'====================================================
Private Function IsKeepShape( _
            ByVal ShapeName As String, _
            ByVal KeepList As Variant) As Boolean

    Dim v

    For Each v In KeepList

        If StrComp(ShapeName, CStr(v), vbTextCompare) = 0 Then

            IsKeepShape = True
            Exit Function

        End If

    Next

End Function