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

This should do what you want. It deletes the shape with the highest top on the page and the shape with the lowest bottom from each page. It's a very naive implementation, because I'm not familiar with Word, but given that my earlier code worked for you, there's a reasonable chance this will do what you want.

Sub removeTopAndBottomMostShapesFromActiveDocument()

    Dim shape As shape
    Dim topShape As shape
    Dim bottomShape As shape

    Dim pageNum
    For pageNum = 1 To ActiveWindow.Panes(1).Pages.Count

        Dim highestPoint, lowestPoint
        highestPoint = 999999
        lowestPoint = -999999

        Set topShape = Nothing
        Set bottomShape = Nothing

        Dim sr As ShapeRange
        Set sr =  ActiveWindow.Panes(1).Pages(pageNum).Rectangles.Item(1).Range.ShapeRange
        sr.Select
        For Each shape In sr
            If shape.Top < highestPoint Then
                Set topShape = shape
                highestPoint = shape.Top
            End If
            If shape.Top + shape.Height > lowestPoint Then
                Set bottomShape = shape
                lowestPoint = shape.Top + shape.Height
            End If
        Next

        If Not topShape Is Nothing Then
            topShape.Delete
        End If
        If Not bottomShape Is Nothing Then
            bottomShape.Delete
        End If

    Next

End Sub

Answer 2

This has already been answered by PatricK, but after looking at some more information I wanted to also post my solution, for future reference.

Another way to do this follows this outline:

1. For each page, if there are more than 2 shapes,
   • find the top-most and bottom-most shape coordinates
   • delete any shapes that don't match these coordinates

Executing the code would look similar to the following, thanks to an answer from this question:

Public Sub delete_firstlast()
'---------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
Dim del_index 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
      'make sure a selectable shape type is being considered
      If shp.RectangleType = wdShapeRectangle Then
        If shp.Top < maxt Then maxt = shp.Top
        If shp.Top > maxb Then maxb = shp.Top
      End If
    Next

    'Delete the top and bottom shapes
    For del_index = pg.Rectangles.Count To 1 Step -1
      If pg.Rectangles(del_index).RectangleType = wdShapeRectangle Then
        Set shp = pg.Rectangles(del_index)
        If shp.Top = maxt Or shp.Top = maxb Then
          pg.Rectangles(del_index).Range.ShapeRange.Delete
        Else
          shp.Range.ShapeRange.Line.Weight = 2
        End If
      End If
    Next

  End If
'go to next page
Next
End Sub

Answer 3

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):

Answer 4

This gets a little dirty as I have to change/restore relative positioning/sizing in order to get absolute page positioning. Also, changing shapes mess up enumeration, so must refer shapes by names:

Sub DeleteEveryPageTopAndBottomShape()
    Dim p As Page, r As Rectangle, s As Shape
    Dim rvp As WdRelativeVerticalPosition, rvs As WdRelativeVerticalSize
    Dim top_s As String, bottom_s As String
    For Each p In ThisDocument.ActiveWindow.ActivePane.Pages
        top_s = vbNullString
        bottom_s = vbNullString
        For Each r In p.Rectangles
            If r.RectangleType = wdShapeRectangle Then
                For Each s In p.Rectangles(1).Range.ShapeRange
                    rvp = s.RelativeVerticalPosition
                    s.RelativeVerticalPosition = wdRelativeVerticalPositionPage
                    s.RelativeVerticalSize = wdRelativeVerticalSizePage
                    If Len(top_s) Then
                        If s.Top < ThisDocument.Shapes(top_s).Top Then top_s = s.Name
                    Else
                        top_s = s.Name
                    End If
                    If Len(bottom_s) Then
                        If s.Top + s.Height > ThisDocument.Shapes(bottom_s).Top + ThisDocument.Shapes(bottom_s).Height Then bottom_s = s.Name
                    Else
                        bottom_s = s.Name
                    End If
                    s.RelativeVerticalPosition = rvp
                    s.RelativeVerticalSize = rvs
                Next
            End If
        Next
        Debug.Print "..."
        If Len(top_s) Then ThisDocument.Shapes(top_s).Delete
        If bottom_s <> top_s Then ThisDocument.Shapes(bottom_s).Delete
    Next
End Sub