Question

背景
这与问题ms word 2010 macro How to select all shapes on a specific page密切相关。但这涉及到我在ShapeRange.Delete尝试为该问题编写答案的代码时获得的意外结果。

问题
所以，设置问题。我能够在每页上更改第一个和最后一个形状的属性。但是，当我使用删除形状（shp.Range.ShapeRange.Line.Weight = 10）的语句替换更改shape属性（shp.Range.ShapeRange.Delete）的语句时，将删除与已更改属性的形状不对应的形状。 为什么.Delete的行为与.Line.Weight不同？

也许我在找错了地方？
这里发生了一些奇怪的事情。我正在使用启用了宏的2007 Word .docm文档。该文档是通过复制SO页面并使用选择性粘贴...无格式文本粘贴到新的新文档中而创建的9页文本。然后我画了一些形状 - 我用矩形，三角形和椭圆形得到了类似的结果。没有形状是内联的。我可以按住Ctrl键单击某些形状来复制它们。但每次，第一个代码块都可以完美地工作：每个页面上的顶部和底部形状都有一个粗体轮廓。即使我移动形状，当我再次运行代码时，每页上的顶部和底部形状都有一个粗体轮廓。

但是，当我运行第二个代码块时，我会遇到不稳定的行为。有时会删除正确的形状。有时他们不是。我可以在运行代码后绘制或按住Ctrl键单击复制形状，然后再次运行，但我无法找到使代码停止按预期工作的模式。即使没有移动形状，也会发生这种情况。简而言之，除了代码之外什么都没有改变，但似乎ShapeRange.Delete方法以一种意想不到的方式发挥作用。

两组代码
这是更改形状属性的代码：

'---------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

'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
      If shp.RectangleType = wdShapeRectangle Then
        If shp.Top < maxt Then maxt = shp.Top
        If shp.Top > maxb Then maxb = shp.Top
      End If
    Next

    'Make top and bottom shapes bold outline
    For Each shp In pg.Rectangles
      If shp.RectangleType = wdShapeRectangle Then
        If shp.Top = maxt Or shp.Top = maxb Then
          shp.Range.ShapeRange.Line.Weight = 10
        Else
          shp.Range.ShapeRange.Line.Weight = 2
        End If
      End If
    Next

  End If
'go to next page
Next

并且，如果我修改代码（仅在最后的For ... Next循环中，请参阅注释），删除不同的形状，甚至留下一些具有line.weight = 10的形状！

'---------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

'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
      If shp.RectangleType = wdShapeRectangle Then
        If shp.Top < maxt Then maxt = shp.Top
        If shp.Top > maxb Then maxb = shp.Top
      End If
    Next

    'Make top and bottom shapes bold outline
    For Each shp In pg.Rectangles
      If shp.RectangleType = wdShapeRectangle Then
        If shp.Top = maxt Or shp.Top = maxb Then
          'here's the modification, nothing else changed
          shp.Range.ShapeRange.Delete
          'shp.Range.ShapeRange.Line.Weight = 10
        Else
          shp.Range.ShapeRange.Line.Weight = 2
        End If
      End If
    Next

  End If
'go to next page
Next

Answer 1

由于您删除形状的方式，很可能会出现问题。从vba中的对象集合中删除项目时，需要从最后一个对象开始，然后按照集合中的第一个对象的方式进行操作。你的代码：

For Each shp In pg.Rectangles
 ....
      shp.Range.ShapeRange.Delete
 ....
Next

应为：

For i = pg.Rectangles.Count to 1 Step -1

 ....
      pg.Rectangles(i).Delete
 ....
Next

这是必要的，因为只要删除第一个对象，该集合就会重新索引自身，现在以前的第二个对象是第一个对象，依此类推。

Word VBA：ShapeRange.Delete意外行为

1 个答案: