Create a Nifty Loader Shape Animation

Read how to Create a a Nifty Loader Shape Animation by Mark Kubiszyn · 2010, 2013 & 2016 (32bit & 64bit)

#back



Nifty Loader Shape Screen Shot

The Code Module

Just one Code Module, 'Loader' is all that is required to create the Loader. The Loader consists of 2 Shapes that are overlaid and then 3 Animations are made. The first is a Rotation of the Foreground Rectangle using an Easing Function. The second is the Fill up of the Background Rectangle. The third is another Rotation of the Foreground Rectangle with a different Easing Function. Put together it's a beautiful thing! Here is the full VBA Code and an Example - just add this to a Code Module and run

' force explicit variable declaration
Option Explicit

' Loader - a simple animated Shape Loader by Mark Kubiszyn for Excel
' https://www.kubiszyn.co.uk/loader.html
' https://www.kubiszyn.co.uk/license.html
' Rubberducked!

' include api's
#If VBA7 And Win64 Then
   ' 64bit
   Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
   Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
   Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
   Private UDFTimerEvent As LongPtr
#Else
   ' 32bit
   Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
   Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
   Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
   Private UDFTimerEvent As Long
#End If

' const scrollbar
Private Const SM_CXVSCROLL = 2

' adjustable constants
Private Const CallbackRate As Double = 0.05
Private Const ForegroundLineWeight As Long = 10
Private Const ForegroundColour As Long = 6248791 '6248791 ' 2302755
Private Const BackgroundColour As Long = 9094372 '7574641 '2302755
Private Const BackgroundFillUpStep As Long = 5
Private Const BackgroundFillUpFrames As Long = 10
Private BackgroundTop As Long
Private BackgroundHeight As Long

' the Loader Shapes
Private Foreground As Shape
Private Background As Shape

' the current Animation
Private Animation As Long

' Frame and Animation Positioning
Private EachFrame As Double
Private TotalFrames As Double
Private StartPosition As Long
Private EndPosition As Long

'-¬ Test the Loader
Public Sub Test()
   'Application.Interactive = False

   Init

   Dim i As Long
   Dim rngCell As Range
   Dim Task As Long
   For Task = 1 To 300

      DoEvents
      For Each rngCell In ActiveSheet.Range("A1:D5").Cells
         DoEvents
         Randomize
         i = i + Rnd(100) - 0.1
         On Error Resume Next
         DoEvents
         rngCell.Interior.Color = RGB(255 * Rnd(i), 81, 181)
         On Error GoTo 0
      Next rngCell
   Next Task

   Killit
   
   'Application.Interactive = True
End Sub

'-¬ Init, initialise
Private Sub Init()
   Debug.Print "Init(): "
   ActiveSheet.Protect userinterfaceonly:=True
   BackgroundTop = 140
   BackgroundHeight = 5
   StartPosition = 45
   EndPosition = 90
   EachFrame = 1
   TotalFrames = 10
   ' create the Shapes
   CreateForegroundShape
   SetAlignment Foreground, msoAlignMiddles, msoAlignCenters
   CreateBackgroundShape
   SetAlignment Background, msoAlignMiddles, msoAlignCenters
   Background.Top = Foreground.Top + Foreground.Height
   Background.Left = Foreground.Left
   ' init the Foreground Rotation Position
   With Foreground
      .Rotation = StartPosition
   End With
   ' set the first animation and fire the Callback Timer
   Animation = 1
   UDFTimerEvent = SetTimer(0&, 0&, CallbackRate * 1000&, AddressOf LoaderCallback)
End Sub

'-¬ Killit, ends the process
Private Sub Killit()
   Debug.Print "Killit(): "
   KillTimer 0&, UDFTimerEvent
   With Foreground
      .Delete
   End With
   With Background
      .Delete
   End With
   ' cleanup
   Set Foreground = Nothing
   Set Background = Nothing
   BackgroundTop = 0
   BackgroundHeight = 0
   Animation = 0
End Sub

'-¬ CreateForegroundShape, create the Foreground animation Shape
Private Sub CreateForegroundShape()
   Debug.Print "CreateForegroundShape(): "
   Set Foreground = Sheet1.Shapes.AddShape(msoShapeRectangle, 100, 100, 40, 40)
   With Foreground
      .Fill.Visible = msoFalse
      .Fill.ForeColor.RGB = ForegroundColour
      .Line.Weight = ForegroundLineWeight
      .Line.Visible = msoTrue
      .Line.ForeColor.RGB = ForegroundColour
      .Line.Transparency = 0
   End With
End Sub

'-¬ CreateForegroundShape, create the Foreground animation Shape
Private Sub CreateBackgroundShape()
   Debug.Print "CreateBackgroundShape(): "
   Set Background = Sheet1.Shapes.AddShape(msoShapeRectangle, 100, BackgroundTop, 40, BackgroundHeight)
   With Background
      .Fill.Visible = msoTrue
      .Line.Visible = msoFalse
      .Fill.ForeColor.RGB = BackgroundColour
      .Visible = msoFalse
      .ZOrder msoSendToBack
   End With
End Sub

Public Sub SetAlignment(ByRef clShape As Shape, ByVal clVerticalPosition As MsoAlignCmd, ByVal clHorizontalPosition As MsoAlignCmd)
   Dim dbX As Double
   Dim dbY As Double
   With clShape
      Select Case clVerticalPosition
      Case msoAlignTops
         dbY = 5
      Case msoAlignMiddles
         dbY = (ActiveWindow.UsableHeight - 19) / 2 - (.Height / 2)
      Case msoAlignBottoms
         dbY = (ActiveWindow.UsableHeight - 19) - (.Height)
      End Select

      Select Case clHorizontalPosition
      Case msoAlignLefts
         dbX = 5                                 '1
      Case msoAlignCenters
         dbX = (ActiveWindow.UsableWidth - GetSystemMetrics(SM_CXVSCROLL)) / 2 - (.Width / 2)
      Case msoAlignRights
         dbX = (ActiveWindow.UsableWidth - GetSystemMetrics(SM_CXVSCROLL)) - (.Width + 2.5)
      End Select
      .Left = dbX
      .Top = dbY
   End With
   dbX = 0: dbY = 0
End Sub

'-¬ easeOutQuad, easing Function
Private Function easeOutQuad(ByVal T As Double, ByVal b As Long, ByVal c As Long, ByVal d As Double) As Variant
   Dim localT As Double
   localT = T
   localT = localT / d
   easeOutQuad = -c * localT * (localT - 2)
End Function

'-¬ easeOutBack, easing Function
Private Function easeOutBack(ByVal T As Double, ByVal b As Long, ByVal c As Long, ByVal d As Double) As Variant
   Dim localT As Double
   localT = T
   localT = localT / d - 1
   easeOutBack = c * (localT * localT * ((1.70158 + 1) * localT + 1.70158) + 1)
End Function

' -¬ LoaderCallback, timer callback procedure
'@Ignore HungarianNotation
Public Sub LoaderCallback(ByVal hwnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
   On Error Resume Next
   'Debug.Print "LoaderCallback(): "
   Select Case Animation
      ' first animation, RotateOutQuad
   Case 1
      'Debug.Print "ANIMATION TYPE RUNNING: " & Animation
      With Foreground
         .Rotation = Round(easeOutQuad(EachFrame, StartPosition, (EndPosition - StartPosition), TotalFrames), 0) - (StartPosition - EndPosition)
      End With
      EachFrame = EachFrame + 1
      If EachFrame > TotalFrames Then
         EachFrame = 1
         Animation = Animation + 1
         With Background
            .Visible = msoTrue
         End With
      End If
      DoEvents
      ' second animation, FillUp
   Case 2
      'Debug.Print "ANIMATION TYPE RUNNING: " & Animation
      EachFrame = EachFrame + 1
      With Background
         .Top = .Top - BackgroundFillUpStep
         .Height = .Height + BackgroundFillUpStep
      End With
      If EachFrame >= BackgroundFillUpFrames Then
         EachFrame = 1
         TotalFrames = 20
         StartPosition = 0
         EndPosition = 90
         Animation = Animation + 1
         Background.Top = Foreground.Top + Foreground.Height
         BackgroundHeight = 5
         With Background
            .Visible = msoFalse
            .Top = BackgroundTop
            .Height = BackgroundHeight
         End With
         With Foreground
            .Fill.Visible = msoTrue
         End With
      End If
      DoEvents
      ' third animation, RotateOutBack
   Case 3
      'Debug.Print "ANIMATION TYPE RUNNING: " & Animation
      With Foreground
         .Rotation = Round(easeOutBack(EachFrame, StartPosition, (EndPosition - StartPosition), TotalFrames), 0) - (StartPosition - EndPosition)
      End With
      EachFrame = EachFrame + 1
      If EachFrame > TotalFrames Then
         Background.Top = Foreground.Top + Foreground.Height
         BackgroundHeight = 5
         EachFrame = 1
         TotalFrames = 10
         StartPosition = 45
         EndPosition = 90
         Animation = Animation + 1
         With Background
            .Visible = msoFalse
         End With
      End If
      DoEvents
   Case 4                                        ' To 10
      'Debug.Print "ANIMATION TYPE RUNNING: " & Animation
      With Foreground
         .Rotation = StartPosition
         .Fill.Visible = msoFalse
      End With
      Animation = 1
   End Select
   On Error GoTo 0
End Sub

Here is a Video of the Loader in action: