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

Question

命令 ActiveDocument.Pages（1）.Shapes.Range.Select 似乎没有在单词2010中起作用。（它曾用于2003年的单词）。

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

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

此致

Firaq pasto

Answer 1

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

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

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

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

删除所有页面的顶部和底部形状（无论是文本还是浮动）。选择它时，下面的代码会检查形状的真实左上角（TL）角和右下角（BR）角。例如。这里的块弧被认为是底部形状而不是左支架。

如果仅关注TL，则删除行x2 = x1 + ...和y2 = y1 + ...，并将所有y2替换为y1，x2替换为{{1}在x1块中。

if end if

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

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

执行一次后（删除所有“Lightning Bolt”形状）：

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

Answer 2

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

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 3

这应该做你想要的。它删除页面顶部最高的形状和每页底部最低的形状。这是一个非常天真的实现，因为我不熟悉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 4

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

另一种方法是遵循这个大纲：

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