vba ms word 2010 宏如何选择特定页面上的所有形状

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

提问by firaq pasto

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

命令 ActiveDocument.Pages(1).Shapes.Range.Select 在 word 2010 中似乎不起作用。（它曾经在 word 2003 中起作用）。

I need to select all the shapes on a specified page (say page 1), then delete the first shape and last shape on each page of a 300 page word document.

我需要选择指定页面（比如第 1 页）上的所有形状，然后删除 300 页 word 文档每页上的第一个形状和最后一个形状。

Any help on how to do this will be of great help.

关于如何做到这一点的任何帮助都会有很大帮助。

Regards

问候

Firaq pasto

Firaq 意大利面

回答by PatricK

UPDATE1 - Removed (only works on inline shapes)

UPDATE1 - 删除（仅适用于内联形状）

UPDATE2 - Removed (only works on inline shapes)

UPDATE2 - 删除（仅适用于内联形状）

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

UPDATE3 - 删除（使用形状名称删除不需要正确的形状，因为它们都可以是相同的）

UPDATE4 - Check and Delete using Shape's ID.

UPDATE4 - 使用 Shape 的 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.

删除所有页面的顶部和底部形状（内嵌文本或浮动）。当您选择形状时，下面的代码会检查形状的真实左上角 (TL) 和右下角 (BR)。EG 这里的 Block Arc 被认为是底部形状，而不是左括号。

If only the TL is of concern, then remove the lines x2 = x1 + ...and y2 = y1 + ...and replace all y2with y1, x2with x1in the if end ifblocks.

如果只有TL是值得关注的，然后取出线x2 = x1 + ...和y2 = y1 + ...替换所有y2带y1，x2与x1在if end if块。

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.

我检查了添加或删除形状时 ID 不会改变。

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

第二次执行后（爆炸形状仍然存在，但位置超出了页面的尺寸 - 这就是浮动形状所做的，其实际位置是相对于锚点的）：

回答by LS_???

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

回答by SJC

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.

这应该做你想做的。它删除页面上顶部最高的形状和每个页面底部最低的形状。这是一个非常幼稚的实现，因为我不熟悉 Word，但考虑到我之前的代码对您有用，这很有可能会满足您的需求。

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

回答by Aaron Thomas

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

PatricK 已经回答了这个问题，但在查看了更多信息后，我还想发布我的解决方案，以供将来参考。

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

1. 对于每个页面，如果有超过 2 个形状，
   • 找到最顶部和最底部的形状坐标
   • 删除任何与这些坐标不匹配的形状

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