爲什麼我的數組被清除？

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數組保持其內容的正確方法如下：

ReDim Preserve oshpColour(1 To shpCount)