VBA PowerPointでShapeを一気に削除するマクロ

こちらのブログで、PowerPoint VBAでFor Eachを使ってShapeを消すとうまくいかないという問題が紹介されていた。

chemiphys.hateblo.jp

やってみたところ、実際に1つ飛ばしで削除される。

実際に検証

Excelで検証してみた。

Sub Excel版ShapeAdd()
    Dim i As Long
    For i = 10 To 200 Step 10
        Sheets(1).Shapes.AddShape _
            msoShapeRectangle, i, i, 100, 50
    Next
End Sub

Sub Excel版ShapeDelete()
    Dim s As Shape
    For Each s In Sheets(1).Shapes
        s.Delete
    Next
End Sub

Excelの場合、For Eachで回してもうまく消えてくれる。

パワポ版で同等のマクロを書いてみたところ、

Sub PPT版ShapeAdd()
    Dim i As Long
    For i = 10 To 200 Step 10
        ActivePresentation.Slides(1).Shapes.AddShape _
            msoShapeRectangle, i, i, 100, 50
    Next
End Sub
Sub PPT版ShapeDel()
    Dim s As Shape
    For Each s In ActivePresentation.Slides(1).Shapes
        s.Delete
    Next
End Sub

一つ飛ばしで削除される。
f:id:t-hom:20170101090907p:plain

原因

これはやはりchemiphysさんの予想通り、Shapes内部のイテレーターがおかしいのだと思う。

この事象はプログラミングの世界ではよくある。
たとえばA～Eの文字が1～5番のインデックスで管理されているとする。
1:A
2:B
3:C
4:D
5:E

1を消すと、こうなるのではなく。
2:B
3:C
4:D
5:E

このようにズレ込む。
1:B
2:C
3:D
4:E

さて、1を消したから次は2だ。
1:B
2:D
3:E

次は3だ。
1:B
2:D

ということで一つ飛ばし。

ExcelのShapesでこの事象が起こらないのにPowerPointだけそうなるのは、同じShapesでも別物だから。
よく似ていて、だいたい同じように扱えるけど微妙に違う。
thom.hateblo.jp

解決法

ひとつはchemiphysさんのブログに書かれているようにFor EachをあきらめてForを使うこと。
For文でIndexを後ろから当たれば消してもズレ込むことはない。

もう一つは一旦Collectionに入れてから削除する方法が考えられる。

一旦Collectionに入れて消すコードは以下のとおり。

Sub PPT版ShapeDel2()
    Dim s As Shape
    Dim c As Collection: Set c = New Collection
    For Each s In ActivePresentation.Slides(1).Shapes
        c.Add s
    Next
    For Each s In c
        s.Delete
    Next
End Sub

ただ2回ループで回す羽目になる。
メインコードでこれをするのは嫌なので、クラスモジュールを使って少し抽象化。

まずクラスモジュールを挿入し、オブジェクト名を「ShapeDeleter」とする。
以下のコードを貼り付け。

Private c As Collection

Private Sub Class_Initialize()
    Set c = New Collection
End Sub

Sub Throw(s As Shape)
    c.Add s
End Sub

Sub Delete()
    For Each x In c
        x.Delete
    Next
End Sub

標準モジュールのコードはこう変わる。

Sub PPT版ShapeDel3()
    Dim SD As ShapeDeleter: Set SD = New ShapeDeleter
    Dim x As Shape
    For Each x In ActivePresentation.Slides(1).Shapes
        SD.Throw x
    Next
    SD.Delete
End Sub