CODEWITHSUNDEEP
arraysvbapowerpoint
SFro
SFro

Reputation: 131

Why is my array being cleared?

I'm designing a slide checker to look for mismatched fonts and colours, and need to keep track of each colour for each shape in an array. My problem is that for some reason the array get's cleared. I've put in flags to check that the array is being properly assigned. As it moves through the loop, it correctly adds 1 to the array, updates the colour for that index, then moves forward. For some reason when it gets to the msgbox check, the array still has the correct number of indexes, but the array is empty for every shape except for the last shape in the loop. For example one shape has 5 lines, another shape has 2. I'll get a msgbox 7 times, but the first 5 are empty, and the next 2 have the actual colour.

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

Upvotes: 0

Views: 57

Answers (1)

omegastripes
omegastripes

Reputation: 12612

The right way to redim an array keeping it content is as follows:

ReDim Preserve oshpColour(1 To shpCount)

Upvotes: 2

Related Questions