为什么我的阵列被清除？

Question

我正在设计一个幻灯片检查器来查找不匹配的字体和颜色，并且需要跟踪数组中每个形状的每种颜色。我的问题是，由于某种原因，数组被清除了。我已经放入标志来检查数组是否被正确分配。当它在循环中移动时，它会正确地将 1 添加到数组中，更新该索引的颜色，然后向前移动。出于某种原因，当它进行 msgbox 检查时，数组仍然具有正确数量的索引，但是除了循环中的最后一个形状之外，每个形状的数组都是空的。例如，一个形状有 5 条线，另一个形状有 2 条线。我会得到一个 msgbox 7 次，但前 5 个是空的，接下来的 2 个是实际颜色。

Private Sub CommandButton1_Click()

Dim x As Integer
Dim i As Integer
Dim a As Integer
Dim b As Integer

Dim shpCount As Integer

Dim lFindColor As Long
Dim oSl As Slide
Dim oSh As Shape

Dim colorsUsed As String
Dim fontsUsed As String

Dim lRow As Long
Dim lCol As Long

Dim shpFont As String
Dim shpSize As String
Dim shpColour As String
Dim shpBlanks As Integer: shpBlanks = 0
Dim oshpColour()

Set oSl = ActiveWindow.View.Slide

    For Each oSh In oSl.Shapes
    '----Shape Check----------------------------------------------------------
        With oSh
            If .HasTextFrame Then
                If .TextFrame.HasText Then
                shpCount = shpCount + .TextFrame.TextRange.Runs.Count
                ReDim oshpColour(1 To shpCount)
                    For x = 1 To .TextFrame.TextRange.Runs.Count
                        a = a + 1
                        oshpColour(a) = .TextFrame.TextRange.Runs(x).Font.Color.RGB
                        shpFont = shpFont & .TextFrame.TextRange.Runs(x).Font.Name & ", "
                        shpSize = shpSize & .TextFrame.TextRange.Runs(x).Font.Size & ", "
                        shpColour = shpColour & .TextFrame.TextRange.Runs(x).Font.Color.RGB & ", "
                    Next
                End If
            End If
    Next

MsgBox "Shape Fonts: " & shpFont & vbCrLf & "Shape Font Sizes: " & shpSize & vbCrLf & "Shape Font Colours: " & shpColour

For b = LBound(oshpColour) To UBound(oshpColour)
MsgBox oshpColour(b)
Next

End Sub

Answer 1

重新调整数组以保持其内容的正确方法如下：

ReDim Preserve oshpColour(1 To shpCount)