Chart Based Animations In Excel VBA

Question

I've been working on re-writing comfortablydrei's answer to this PPCG Question regarding creating a illusion animation in pure Excel VBA. So far, I've been able to rewrite the code to function in VBA, and to get the cycle time for the animation down substantially, but have run into an issue where I am GPU-limited on my current system (that is, the animation causes the GPU to pin @ 100% 3D usage)

To reduce the cycle time, I have tried

• modifying how frequently the VBA.DoEvents call is made, and while this does reduce the time, it also breaks the animation severely
• Adding Application.ScreenUpdating = False and "=True calls, and this appears not to work
• reducing the code in the Animate Subroutine to be as simple as I can, with the result being the below

Is there anything that I have missed (general or case-specific tricks or tips) that can make this faster, or is this about as good as can be expected for animations made in Excel VBA?

I am pimarily concerned with the performance of the animate subroutine, and am otherwise only concerned with the readiblity of the other routines

---

Animate Subroutine

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''
''  Private (looping) Animation Subroutine
''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub animate()
    
    '' dim vars
    Dim iter    As Integer, _
        iPos    As Double, _
        iX      As Double, _
        iY      As Double
        
    '' Debug Vars
    #If DebugMode Then
        Dim t As Long
        Debug.Print "Animation Cycle Time (sec)"
    #End If
    
nextLoop:
    '' do events - allow for screen update, and event handling
    Call VBA.DoEvents
    
    '' Debug Timing
    #If DebugMode Then
        If rad > 0 And rad <= stp Then
           If t > 0 Then Debug.Print Timer - t
           Let t = Timer
        End If
    #End If
    
    '' loop over shapes
    For iter = 1 To numPnts
        
        '' calculate the new position of shape
        Let iPos = Pi * (iter - 1) / numPnts
        If rad + iPos < 0 Then GoTo nextIter
        Let iX = Sin(iPos)
        Let iY = Cos(iPos)
        
        '' set shapes location
        Let shp(iter).Left = plotCenterX - shpSize / 2 + (iX * plotScale / 2) * Cos(rad + iPos)
        Let shp(iter).Top = plotCenterY - shpSize / 2 + (iY * plotScale / 2) * Cos(rad + iPos)
        
nextIter:
    Next iter
    
   
    '' get decimal mod of the rad with respect to tau
    Let rad = rad + stp
    Let rad = Round(rad - Fix(rad / Tau) * Tau, 14)

    GoTo nextLoop
        
End Sub

---

Full Commented Code

'' Module Options
Option Compare Binary
Option Explicit
Option Base 1

'' Global Vars
Global app            As Excel.Application, _
       twb            As Excel.Workbook, _
       cht            As Excel.Chart, _
       ser            As Excel.Series, _
       shp()          As Excel.Shape, _
       dat()          As Double, _
       rad            As Double

'' Positioning Vars
Global plotCenterX    As Double, _
       plotCenterY    As Double, _
       plotScale      As Double

'' Naming Constants
Private Const chtName As String = "Pie Chart"
Private Const serName As String = "DataSheet"
Private Const numPnts As Integer = 8

'' Shape Constants
Private Const shpType As Long = MsoAutoShapeType.msoShapeRectangle
Private Const shpSize As Long = 15

'' Math Constants
Public Const Pi       As Double = 3.14159265358979
Public Const Tau      As Double = 6.28318530717959
Public Const stp      As Double = 0.03

'' Conditional Compilation Switch for Debug Mode -
''
'' When True, shows timing for a complete animation cycle
''   ( rad - 0 to rad = 2*pi )
#Const DebugMode = True


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''
''  Public Main Subroutine
''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub Main()
    
    #If DebugMode Then
        Debug.Print
        Debug.Print "Initializing"
    #End If
    
    Dim iter          As Integer, _
        colors        As Variant, _
        pnt           As Excel.Point

    ''  initialize global variables, incl. chart and Data series
    Call pInit
    
    '' To avoid having to upload another module, the output of Scales.HuePalette(8) is hardcoded
    ' Let colors = scales.HuePalette(numPnts)
    Let colors = [{7173880,38603,44664,6798848,12893952,16754944,16743623,13394431}]
    
    
    
    ''  Format the chart as desired
    With ser
        Let .Name = "Spacers"
        Let .Values = "={" & Replace(Space(2 * numPnts - 1), " ", "1,") & "1}"
        With .Format
            Let .Line.ForeColor.RGB = rgbWhite
            Let .Line.Visible = True
            Let .Line.Weight = 1.5
    End With: End With

    Call VBA.DoEvents '' On some machines, the cht.HasTitle
                      '' fails to let if this is not included
    
    '' clean up the view
    Let cht.HasTitle = False
    Let cht.HasLegend = False
    
    Let rad = 0
    
    Dim iPos          As Double, _
        iX            As Double, _
        iY            As Double
    
    '' give each section a nice gradiant, because why not
    For iter = 1 To 2 * numPnts
        Set pnt = ser.Points(iter)
        With pnt.Format.Fill
            Call .TwoColorGradient(msoGradientVertical, 2)
            Let .GradientStops(1).Color.RGB = &HFEFEFE
            Let .GradientStops(2).Color.RGB = &HF2F2F2
            Let .GradientAngle = (360 / (2 * numPnts)) * (iter - 0.5) + 90
        End With
    Next iter
    
    
    '' place the shapes on the edges of the circle
    For iter = 1 To numPnts
        Let iPos = Pi * (iter - 1) / numPnts
        Let iX = Sin(iPos)
        Let iY = Cos(iPos)
        
        '' setup the shapes with a nice color
        With shp(iter)
            Let .Fill.ForeColor.RGB = colors(iter)
            Let .Line.ForeColor.RGB = rgbBlack
            Let .Line.Weight = 0.75
            
            Let .Left = plotCenterX - shpSize / 2 + iX * plotScale / 2
            Let .Top = plotCenterY - shpSize / 2 + iY * plotScale / 2
        End With
    Next iter
    
    
    Let rad = -Pi
    
    #If DebugMode Then
        Debug.Print "Initialization Complete. Beginnning Animation"
        Debug.Print
    #End If
    
    Call animate
    
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''
''  Private (looping) Animation Subroutine
''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub animate()
    
    '' dim vars
    Dim iter    As Integer, _
        iPos    As Double, _
        iX      As Double, _
        iY      As Double
        
    '' Debug Vars
    #If DebugMode Then
        Dim t As Long
        Debug.Print "Animation Cycle Time (sec)"
    #End If
    
nextLoop:
    '' do events - allow for screen update, and event handling
    Call VBA.DoEvents
    
    '' Debug Timing
    #If DebugMode Then
        If rad > 0 And rad <= stp Then
           If t > 0 Then Debug.Print Timer - t
           Let t = Timer
        End If
    #End If
    
    '' loop oveer shapes
    For iter = 1 To numPnts
        
        '' calculate the new position of shape
        Let iPos = Pi * (iter - 1) / numPnts
        If rad + iPos < 0 Then GoTo nextIter
        Let iX = Sin(iPos)
        Let iY = Cos(iPos)
        
        '' set shapes location
        Let shp(iter).Left = plotCenterX - shpSize / 2 + (iX * plotScale / 2) * Cos(rad + iPos)
        Let shp(iter).Top = plotCenterY - shpSize / 2 + (iY * plotScale / 2) * Cos(rad + iPos)
        
nextIter:
    Next iter
    
   
    '' get decimal mod of the rad with respect to tau
    Let rad = rad + stp
    Let rad = Round(rad - Fix(rad / Tau) * Tau, 14)

    GoTo nextLoop
        
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''
''  Private Initialization Subroutines
''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'' Main Initialization Sub, Calls all following Init Calls
Private Sub pInit()
    ReDim shp(1 To numPnts)
    ReDim dat(1 To numPnts, 0 To 1)
    Set app = Excel.Application
    Set twb = app.ThisWorkbook
    Let app.Calculation = xlCalculationManual
    Call pInitChart
    Call pInitSeries
    Call pInitShapes
    Call pInitPlotVars
End Sub

'' Initialixes the Pie Chart, cht
Private Sub pInitChart()
    If Not cht Is Nothing Then Exit Sub
    If KeyExists(app.Charts, chtName) Then Set cht = app.Charts(chtName): Exit Sub
    Set cht = app.Charts.Add
    Let cht.Name = chtName
    Let cht.ChartType = xlPie
End Sub

'' Initialixes Initializes the data series, ser, in cht
Private Sub pInitSeries()
    Dim i As Long
    With cht
        For i = .SeriesCollection.Count To 1 Step -1
            Call .SeriesCollection(i).Delete
        Next i
        Call .SeriesCollection.NewSeries
        Set ser = .SeriesCollection(1)
    End With
End Sub

'' adds array of shapes to the chart workbook object
Private Sub pInitShapes()
    Dim i As Long
    For i = cht.Shapes.Count To 1 Step -1
        Call cht.Shapes(i).Delete
    Next i
    For i = 1 To numPnts Step 1
        Set shp(i) = cht.Shapes.AddShape(shpType, shpSize * i, shpSize * i, shpSize, shpSize)
    Next i
End Sub

'' initializes the ploting vars
Private Sub pInitPlotVars()
    Let plotScale = cht.PlotArea.InsideHeight
    Debug.Assert plotScale = cht.PlotArea.InsideWidth '' if this fails the chart is not square
    Let plotCenterX = plotScale / 2 + cht.PlotArea.InsideLeft
    Let plotCenterY = plotScale / 2 + cht.PlotArea.InsideTop
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''
''  Generic functions
''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''  Takes an object, and returns a bool which describes if `key` is a vaild key
''    for either the default method of the object or for the `item` method of
''    object
Public Function KeyExists(ByRef objCol As Object, ByVal key As String) As Boolean
    Dim var As Variant, _
        k   As Boolean
    On Error Resume Next
    With VBA.Err
        Let var = objCol(key):      Let k = k Or (.Number = 0): Call .Clear '' test let and default
        Set var = objCol(key):      Let k = k Or (.Number = 0): Call .Clear '' test set and default
        Let var = objCol.Item(key): Let k = k Or (.Number = 0): Call .Clear '' test let and item
        Set var = objCol.Item(key): Let k = k Or (.Number = 0): Call .Clear '' test set and item
    End With
    Let KeyExists = k
    On Error GoTo 0
End Function

---

Current Performance:

Win 11P, Excel 2021, R9-5950X, RTX 3070Ti 8GB \$ \approx1.75\text{ sec} \$ - Limited by VBA.DoEvents

Win 10P, Excel 2016, I7 8850H, Quadro P2000 4GB \$ \approx1.99\text{ sec} \$

Win 10P, i7 8850H, Intel Integrated Graphics \$\approx8.07\text{ sec}\$