Word VBA: ShapeRange.Delete unexpected behavior

Question

The Background
This is closely related to the question ms word 2010 macro How to select all shapes on a specific page. But this concerns an unexpected result I'm getting from ShapeRange.Delete, when trying to code an answer for that question.

The Question
So, to set up the question. I'm able to change properties of the first and last shape on each page. However, when I replace the statement that changes the shape property (shp.Range.ShapeRange.Line.Weight = 10) with a statement that deletes the shape (shp.Range.ShapeRange.Delete), shapes are deleted that do not correspond to the shapes that had the property changed. Why does .Delete not act on the same shapes as .Line.Weight?

Maybe I'm looking in the wrong place?
There are a few strange things happening here. I'm working on a 2007 Word .docm document with macros enabled. The document is 9 pages of text created by copying a SO page and pasting into the new fresh document with Paste Special...Unformatted Text. I then draw some shapes - I've gotten similar results with rectangles, triangles, and ovals. No shapes are inline. I may ctrl-click some shapes to duplicate them. But every time, the first code block works perfectly: the top and bottom shapes on each page have a bold outline. Even if I move shapes around, when I run the code again only the top and bottom shapes on each page have a bold outline.

However, when I run the second code block I get erratic behavior. Sometimes the correct shapes are deleted. Sometimes they're not. I may draw or ctrl-click-copy shapes after running code, then run again, but I can't find a pattern to what makes the code stop working as expected. This occurs even when the shapes are not moved. In short, nothing but the code changes, yet it seems the ShapeRange.Delete method is acting in an unexpected way.

The two sets of code
Here's the code that changes the shape properties:

'---------find the first and last shape on each page, make bold-----------
Dim pg As Page
Dim shp As Variant
Dim shp_count As Long, maxt As Long, maxb As Long

'for each page
For Each pg In ActiveDocument.Windows(1).Panes(1).Pages

  'find the number of shapes
  shp_count = 0
  For Each shp In pg.Rectangles
    If shp.RectangleType = wdShapeRectangle Then shp_count = shp_count + 1
  Next

  'if there are more than 2 shapes on a page, there
  'are shapes to be made bold
  If shp_count > 2 Then

    'prime the maxt and maxb for comparison
    'by setting to the first shape
    For Each shp In pg.Rectangles
      If shp.RectangleType = wdShapeRectangle Then
        maxt = shp.Top
        maxb = maxt
        Exit For
      End If
    Next

    'set maxt and maxb
    For Each shp In pg.Rectangles
      If shp.RectangleType = wdShapeRectangle Then
        If shp.Top < maxt Then maxt = shp.Top
        If shp.Top > maxb Then maxb = shp.Top
      End If
    Next

    'Make top and bottom shapes bold outline
    For Each shp In pg.Rectangles
      If shp.RectangleType = wdShapeRectangle Then
        If shp.Top = maxt Or shp.Top = maxb Then
          shp.Range.ShapeRange.Line.Weight = 10
        Else
          shp.Range.ShapeRange.Line.Weight = 2
        End If
      End If
    Next

  End If
'go to next page
Next

And, if I modify the code such (only in the last For...Next loop, see the comment), different shapes are deleted, even leaving some shapes that have a line.weight = 10!

'---------find the first and last shape on each page, make bold-----------
Dim pg As Page
Dim shp As Variant
Dim shp_count As Long, maxt As Long, maxb As Long

'for each page
For Each pg In ActiveDocument.Windows(1).Panes(1).Pages

  'find the number of shapes
  shp_count = 0
  For Each shp In pg.Rectangles
    If shp.RectangleType = wdShapeRectangle Then shp_count = shp_count + 1
  Next

  'if there are more than 2 shapes on a page, there
  'are shapes to be made bold
  If shp_count > 2 Then

    'prime the maxt and maxb for comparison
    'by setting to the first shape
    For Each shp In pg.Rectangles
      If shp.RectangleType = wdShapeRectangle Then
        maxt = shp.Top
        maxb = maxt
        Exit For
      End If
    Next

    'set maxt and maxb
    For Each shp In pg.Rectangles
      If shp.RectangleType = wdShapeRectangle Then
        If shp.Top < maxt Then maxt = shp.Top
        If shp.Top > maxb Then maxb = shp.Top
      End If
    Next

    'Make top and bottom shapes bold outline
    For Each shp In pg.Rectangles
      If shp.RectangleType = wdShapeRectangle Then
        If shp.Top = maxt Or shp.Top = maxb Then
          'here's the modification, nothing else changed
          shp.Range.ShapeRange.Delete
          'shp.Range.ShapeRange.Line.Weight = 10
        Else
          shp.Range.ShapeRange.Line.Weight = 2
        End If
      End If
    Next

  End If
'go to next page
Next

Stewbob Stewbob · Accepted Answer · 2013-09-17T20:34:11

The problem is most likely occurring because of the way that you are deleting your shapes. When deleting items from a collection of objects in vba, you need to start with the last object and work your way toward the first object in the collection. Your code:

For Each shp In pg.Rectangles
 ....
      shp.Range.ShapeRange.Delete
 ....
Next

should read:

For i = pg.Rectangles.Count to 1 Step -1

 ....
      pg.Rectangles(i).Delete
 ....
Next

This is necessary, because as soon as you delete the first object, the collection will re-index itself, and now the formerly 2nd object is the 1st object and so on.

Word VBA: ShapeRange.Delete unexpected behavior

1 Answers