I've been working on re-writingcomfortablydrei's answer tothis 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 theVBA.DoEvents call is made, and while this does reduce the time, it also breaks the animation severely
• AddingApplication.ScreenUpdating = False and"=True calls, and this appears not to work
• reducing the code in theAnimate 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 theanimate 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 OptionsOption Compare BinaryOption ExplicitOption Base 1'' Global VarsGlobal 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 VarsGlobal plotCenterX    As Double, _       plotCenterY    As Double, _       plotScale      As Double'' Naming ConstantsPrivate Const chtName As String = "Pie Chart"Private Const serName As String = "DataSheet"Private Const numPnts As Integer = 8'' Shape ConstantsPrivate Const shpType As Long = MsoAutoShapeType.msoShapeRectanglePrivate Const shpSize As Long = 15'' Math ConstantsPublic Const Pi       As Double = 3.14159265358979Public Const Tau      As Double = 6.28318530717959Public 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 CallsPrivate 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 pInitPlotVarsEnd Sub'' Initialixes the Pie Chart, chtPrivate 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 = xlPieEnd Sub'' Initialixes Initializes the data series, ser, in chtPrivate 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 WithEnd Sub'' adds array of shapes to the chart workbook objectPrivate 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 iEnd Sub'' initializes the ploting varsPrivate 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.InsideTopEnd 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''    objectPublic 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 0End Function

Current Performance:

Win 11P, Excel 2021, R9-5950X, RTX 3070Ti 8GB\$ \approx1.75\text{ sec} \$ - Limited byVBA.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}\$

• \$\begingroup\$If performance is key, then it wouldn't hurt to profile your code and determine exactly the source of slowness. Is it theDoEvents calls (in which case make this asynchronous using a winapi timer instead ofDoEvents to avoid unnecessary processing)? Maybe it's the writing to the chart (use an algorithmic change to reduce the number of hits, try doing all your writing at once)? Perhaps there's some kind of caching on Excel's part that slows the animation over time. Or something else entirely. Profile the code using a high performance stopwatch to determine the source of bottlenecks.\$\endgroup\$

  Greedo

  – Greedo

  2020-03-20 07:45:01 +00:00

  CommentedMar 20, 2020 at 7:45

0

Start asking to get answers

Find the answer to your question by asking.

Explore related questions

See similar questions with these tags.