Efficient way to animate changing colors for a large number of shapes?

[nannerdw]

I'm trying to create an animated process flow diagram for an assembly line, where each process is represented by a color-changing shape. white=empty. blue,green,and yellow=different product types occupying each process. outlined in red=finished and waiting on the next process to advance.

I can't really upload the code, since it's full of specific company info., but it basically loops once a second (actual line speed, not animation playback speed) through each job from finish to start, checking to see whether the job is complete, and advances if the next job is open. Once it advances, the elapsed time for the current job resets to 0. DoEvents occurs at the end of each time step to refresh the graphics.

This seems to work efficiently enough for a small number of processes (about 8-10), but when I try to go full-scale and add about 100 processes, it just slows to a crawl, and DoEvents fails to refresh the image. I tried switching between Application.ScreenUpdating = False/True, but it caused a lot of flickering and ran even slower.

I've been looking into creating a ''process" class or dictionary, but I'm not sure if it would be any more efficient than the current array setup.

I'm also considering processing all of the data first, storing it into large 2d arrays spanning the course of about 20 minutes, ColorAtTime(100,1200), and retrieving that info later for the animation.

What's the most efficient way to change the colors of so many shapes at once? Right now, the colors for each job are stored as byte variables in an array. Is it possible to make a shaperange for each different color and update all of the shapes at the same time without having to loop through each one individually?

[Andy Pope]

Hard to say without at least seeing some code.

This example will generate 400 rectangles and alter their fill colour in various ways.

Sub Ani()
    Dim shpTemp(1 To 20, 1 To 20) As Shape
    Dim lngRow As Long
    Dim lngCol As Long
    Dim rngCanvas As Range
    Dim lngIndex As Long
    Dim lngColor As Long
    Dim lngMulti(1 To 10, 1 To 2) As Long
    Dim lngItem As Long
    
    ' create shapes
    Application.ScreenUpdating = False
    Set rngCanvas = Range("B2:U21")
    For lngRow = 1 To rngCanvas.Rows.Count
        For lngCol = 1 To rngCanvas.Columns.Count
            With rngCanvas.Cells(lngRow, lngCol)
                Set shpTemp(lngRow, lngCol) = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
                                                .Left + 1, .Top + 1, .Width - 2, .Height - 2)
            End With
            With shpTemp(lngRow, lngCol)
                .Name = "box" & Format(lngRow, "00") & Format(lngCol, "00")
                .Fill.ForeColor.RGB = RGB(255, 0, 0)
                .Line.Visible = False
            End With
        Next
    Next
    Application.ScreenUpdating = True

    For lngIndex = 1 To 3
        For lngRow = 1 To rngCanvas.Rows.Count
            For lngCol = 1 To rngCanvas.Columns.Count
                shpTemp(lngRow, lngCol).Fill.ForeColor.RGB = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
                DoEvents
            Next
        Next
    Next

    For lngRow = 1 To rngCanvas.Rows.Count
        For lngCol = 1 To rngCanvas.Columns.Count
            shpTemp(lngRow, lngCol).Fill.ForeColor.RGB = 0
        Next
    Next
    DoEvents

    For lngIndex = 1 To 3
        For lngItem = 1 To 10
            lngMulti(lngItem, 1) = Int(Rnd * 19) + 1
            lngMulti(lngItem, 2) = Int(Rnd * 19) + 1
        Next
        For lngColor = 1 To 255
            For lngItem = 1 To 10
                lngRow = lngMulti(lngItem, 1)
                lngCol = lngMulti(lngItem, 2)
                shpTemp(lngRow, lngCol).Fill.ForeColor.RGB = RGB(lngColor, lngColor, lngColor)
            Next
            DoEvents
        Next
        For lngItem = 1 To 10
            lngRow = lngMulti(lngItem, 1)
            lngCol = lngMulti(lngItem, 2)
            shpTemp(lngRow, lngCol).Fill.ForeColor.RGB = 0
        Next
        DoEvents
    Next
    
    For lngColor = 1 To 255 Step 10
        For lngRow = 1 To rngCanvas.Rows.Count
            For lngCol = 1 To rngCanvas.Columns.Count
                shpTemp(lngRow, lngCol).Fill.ForeColor.RGB = RGB(lngColor, lngColor, lngColor)
            Next
        Next
        DoEvents
    Next
    
    For lngRow = 1 To rngCanvas.Rows.Count
        For lngCol = 1 To rngCanvas.Columns.Count
            shpTemp(lngRow, lngCol).Delete
        Next
    Next

End Sub