Power Point VBA宏：运行时错误9

Question

我遇到了以下代码的运行时错误9：下标超出范围，但最初运行良好。 但是后来当我协作所有模块来创建加载项时，显示错误。

Sub SelectSimilarshapes()

  Dim sh As Shape
  Dim shapeCollection() As String
  Set sh = ActiveWindow.Selection.ShapeRange(1)
  ReDim Preserve shapeCollection(0)
  shapeCollection(0) = sh.Name
  Dim otherShape As Shape
  Dim iShape As Integer
  iShape = 1
  For Each otherShape In ActiveWindow.View.Slide.Shapes
    If otherShape.Type = sh.Type _
    And otherShape.AutoShapeType = sh.AutoShapeType _
    And otherShape.Type <> msoPlaceholder Then
    If (otherShape.Name <> sh.Name) Then
      ReDim Preserve shapeCollection(1 + iShape)
      shapeCollection(iShape) = otherShape.Name
      iShape = iShape + 1
    End If
    End If

  Next otherShape
  ActiveWindow.View.Slide.Shapes.Range(shapeCollection).Select


  Select Case iShape
    Case 1
      MsgBox "Sorry, no shapes matching your search criteria were found"

    Case Else
      MsgBox "Shapes matching your search criteria were found and are selected"
  End Select
NormalExit:
Exit Sub

err1:
     MsgBox "You haven't selected any object"
     Resume NormalExit:
End Sub

Answer 1

声明或调整数组大小时，应为此数组指定下索引和上索引

ReDim Preserve shapeCollection(0 To 0)

代替

ReDim Preserve shapeCollection(0)

---

在其他语言中，数组通常从0开始索引，也不例外。

在VBA中，数组可以从任何值索引，即

Dim array(5 To 10) As String

如果跳过较低的索引，它将具有默认值。 内置默认值为0，但是可以使用以下语句将其更改为1：

Option Base 1

放置在模块顶部。 如果模块中有这样的语句，则所有未声明其下位索引的数组均从1开始索引。

优良作法是始终指定数组的两个索引，因为您永远不知道您的Sub / Function是否将移至另一个模块。 并且即使您的数组从0开始索引，这个新模块也可以具有Option Base 1 ，并且您的数组突然从1而不是从0开始索引。

---

我想这发生在您的代码中。

更改方法如下：

Sub SelectSimilarshapes()
    Dim sh As Shape
    Dim shapeCollection() As String
    Dim otherShape As Shape
    Dim iShape As Integer


    Set sh = ActiveWindow.Selection.ShapeRange(1)
    ReDim Preserve shapeCollection(0 To 0)
    shapeCollection(0) = sh.Name
    iShape = 1

    For Each otherShape In ActiveWindow.View.Slide.Shapes
        If otherShape.Type = sh.Type _
            And otherShape.AutoShapeType = sh.AutoShapeType _
            And otherShape.Type <> msoPlaceholder Then

            If (otherShape.Name <> sh.Name) Then
                ReDim Preserve shapeCollection(0 To 1 + iShape)
                shapeCollection(iShape) = otherShape.Name
                iShape = iShape + 1
            End If

        End If
    Next otherShape
    ActiveWindow.View.Slide.Shapes.Range(shapeCollection).Select


    Select Case iShape
        Case 1
            MsgBox "Sorry, no shapes matching your search criteria were found"
        Case Else
            MsgBox "Shapes matching your search criteria were found and are selected"
    End Select

NormalExit:
    Exit Sub

err1:
    MsgBox "You haven't selected any object"
    Resume NormalExit:
End Sub