ms word 2010 macro How to select all shapes on a specific page

Question

The command ActiveDocument.Pages(1).Shapes.Range.Select doesnot seem to work in word 2010. (It used to work in word 2003).

I need to select all the shapes on a speci

Answer 1

UPDATE1 - Removed (only works on inline shapes)

UPDATE2 - Removed (only works on inline shapes)

UPDATE3 - Removed (Delete using the Shape's Name not necessary the right Shape as they can all be the same)

UPDATE4 - Check and Delete using Shape's ID.

To delete the top and bottom shapes of all the pages (be it inline with text or floating). Code below checks for the real Top Left (TL) corner and Bottom Right (BR) corner of the shape when you select it. E.G. The Block Arc here is the considered the Bottom shape instead of the Left Bracket.

If only the TL is of concern, then remove the lines x2 = x1 + ... and y2 = y1 + ... and replace all y2 with y1, x2 with x1 in the if end if blocks.

Sub DeleteAllTopBottomShapes()
    On Error Resume Next
    Dim aShapeTopID() As Variant ' ID of shape to delete with min vertical location
    Dim aShapeBottomID() As Variant ' ID of shape to delete with max vertical location
    Dim aShapeMinX() As Variant ' position of shape (min horizontal location)
    Dim aShapeMinY() As Variant ' position of shape (min vertical location)
    Dim aShapeMaxX() As Variant ' position of shape (max horizontal location)
    Dim aShapeMaxY() As Variant ' position of shape (max vertical location)
    Dim x1 As Single, y1 As Single ' x and y-axis values (top left corner of shape)
    Dim x2 As Single, y2 As Single ' x and y-axis values (bottom right corner of shape)
    Dim i As Long, n As Long ' counters
    Dim oSh As Shape

    'Application.ScreenUpdating = False
    ' Prepare arrays
    n = ActiveDocument.ComputeStatistics(wdStatisticPages) - 1
    ReDim aShapeTopID(n)
    ReDim aShapeBottomID(n)
    ReDim aShapeMinX(n)
    ReDim aShapeMinY(n)
    ReDim aShapeMaxX(n)
    ReDim aShapeMaxY(n)
    ' Preset the minimum axis values to max according to the pagesetup
    For i = 0 To n
        aShapeMinX(i) = ActiveDocument.PageSetup.PageHeight
        aShapeMinY(i) = ActiveDocument.PageSetup.PageWidth
    Next
    ' Search for the top and bottom shapes
    For Each oSh In ActiveDocument.Shapes
        With oSh.Anchor
            i = .Information(wdActiveEndAdjustedPageNumber) - 1
            x1 = .Information(wdHorizontalPositionRelativeToPage) + oSh.Left
            y1 = .Information(wdVerticalPositionRelativeToPage) + oSh.Top
            x2 = x1 + oSh.Width
            y2 = y1 + oSh.Height
        End With
        Application.StatusBar = "Checking Shape """ & oSh.Name & """ (ID: " & oSh.ID & ") on Page " & i + 1 & " TL:(" & x1 & ", " & y1 & ") BR:(" & x2 & ", " & y2 & ")"
        Debug.Print "Pg." & i + 1 & vbTab & "(ID:" & oSh.ID & ") """ & oSh.Name & """" & vbTab & "TL:(" & x1 & ", " & y1 & ") BR:(" & x2 & ", " & y2 & ")"
        ' Check for Top Left corner of the Shape
        If y1 < aShapeMinY(i) Then
            aShapeMinY(i) = y1
            aShapeMinX(i) = x1
            aShapeTopID(i) = oSh.ID
        ElseIf y1 = aShapeMinY(i) Then
            If x1 < aShapeMinX(i) Then
                aShapeMinX(i) = x1
                aShapeTopID(i) = oSh.ID
            End If
        End If
        ' Check for Bottom Right corner of the Shape
        If y2 > aShapeMaxY(i) Then
            aShapeMaxY(i) = y2
            aShapeMaxX(i) = x2
            aShapeBottomID(i) = oSh.ID
        ElseIf y2 = aShapeMaxY(i) Then
            If x2 > aShapeMaxX(i) Then
                aShapeMaxX(i) = x2
                aShapeBottomID(i) = oSh.ID
            End If
        End If
    Next
    Debug.Print
    ' Delete the Top and Bottom shapes
    For i = 0 To n
        If Not IsEmpty(aShapeTopID(i)) Then
            For Each oSh In ActiveDocument.Shapes
                If oSh.ID = aShapeTopID(i) Then
                    Application.StatusBar = "Deleting Top shape """ & oSh.Name & """ (ID: " & aShapeTopID(i) & ") on page " & i + 1
                    Debug.Print "Deleting Top shape """ & oSh.Name & """ (ID: " & aShapeTopID(i) & ") on page " & i + 1
                    oSh.Delete
                    Exit For
                End If
            Next
        End If
        If Not IsEmpty(aShapeBottomID(i)) Then
            For Each oSh In ActiveDocument.Shapes
                If oSh.ID = aShapeBottomID(i) Then
                    Application.StatusBar = "Deleting Bottom shape """ & oSh.Name & """ (ID: " & aShapeBottomID(i) & ") on page " & i + 1
                    Debug.Print "Deleting Bottom shape """ & oSh.Name & """ (ID: " & aShapeBottomID(i) & ") on page " & i + 1
                    oSh.Delete
                    Exit For
                End If
            Next
        End If
    Next
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

I checked that the ID does not change when a Shape is added or Deleted.

Screenshot of test doc (wicked it so all "Lightning Bolts" are the Top and Bottom):

After executed once (all the "Lightning Bolt" shapes are deleted):

After 2nd execute (the Explosion Shape is still there but position is out of the page's dimension - this is what floating shapes do, its actual position is relative to the Anchor):