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

Question

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

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

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

问候

菲拉克意大利面

Answer 1

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

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

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

UPDATE4 - 使用 Shape 的 ID 检查和删除。

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

如果仅关注 TL，则删除这些行x2 = x1 + ...，并将块中的y2 = y1 + ...所有内容替换y2为y1, 。x2x1if 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

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

测试文档的屏幕截图（邪恶，所以所有“闪电”都是顶部和底部）：

执行一次后（所有“闪电”形状都被删除）：

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

Answer 2

这应该做你想要的。它从每一页中删除页面顶部最高的形状和底部最低的形状。这是一个非常幼稚的实现，因为我对 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

Answer 3

这有点脏，因为我必须更改/恢复相对定位/大小才能获得绝对页面定位。此外，更改形状会混淆枚举，因此必须按名称引用形状：

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

Answer 4

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

执行此操作的另一种方法遵循此大纲：

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

由于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