├── Animations.bas ├── HandCursor.ico ├── LICENSE ├── README.md ├── UserformAnimation.gif └── animations.xlsm /Animations.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Animations" 2 | Option Explicit 3 | Option Compare Text 4 | Option Private Module 5 | 6 | 'Sleep FUNCTIONLITY 7 | #If VBA7 And Win64 Then 8 | Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 9 | #Else 10 | Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 11 | #End If 12 | 13 | 'USED FOR MICRO TIMER 14 | #If VBA7 Then 15 | Private Declare PtrSafe Function getFrequency Lib "kernel32" Alias _ 16 | "QueryPerformanceFrequency" (cyFrequency As Currency) As Long 17 | Private Declare PtrSafe Function getTickCount Lib "kernel32" Alias _ 18 | "QueryPerformanceCounter" (cyTickCount As Currency) As Long 19 | #Else 20 | Private Declare Function getFrequency Lib "kernel32" Alias _ 21 | "QueryPerformanceFrequency" (cyFrequency As Currency) As Long 22 | Private Declare Function getTickCount Lib "kernel32" Alias _ 23 | "QueryPerformanceCounter" (cyTickCount As Currency) As Long 24 | #End If 25 | 26 | 27 | '@AUTHOR: ROBERT TODAR 28 | '@LICENCE: MIT 29 | 30 | 'DEPENDENCIES 31 | ' - REFERENCE SET FOR 'MICROSOFT SCRIPTING RUNTIME' FOR Scripting.Dictionary 32 | ' - MUST HAVE API'S ABOVE. 33 | ' - MOST OF THESE FUNCTIONS RELY ON EACH OTHER, THIS MODULE SHOULD STAY IN TACT. 34 | 35 | 'PUBLIC METHODS/FUNCTIONS 36 | ' - Transition 37 | ' - Effect 38 | ' - MicroTimer 39 | 40 | 'PRIVATE METHODS/FUNCTIONS 41 | ' - AllTransitionsComplete 42 | ' - TransitionComplete 43 | ' - IncrementElement 44 | ' - easeInAndOut 45 | 46 | 'NOTES: 47 | ' - CREATED THIS TO MAKE TRANSITIONS AND ANIMATIONS IN USERFORMS. 48 | ' - A LITTLE SIMIALR TO CSS. KINDA :) 49 | ' - ALSO CAN ANIMATE THE USERFORM AS WELL (SUCH AS A SLIDE IN EFFECT) 50 | 51 | 'TODO: 52 | ' - CHANGE THE WAY THAT THE EFFECT IS CALLED, THAT WAY THERE MIGHT BE AN OPTION OF WHAT TYPE 53 | ' - OF EFFECT, SUCH AS LINER, EASE-OUT, EASE-IN, POSSIBLY EVEN Bezier CURVE. 54 | ' 55 | ' - NEED TO ADD A FUNCTION FOR FINDING THE USERFORM FOR REFRESH, CURRENTLY JUST GRABS IT FROM 56 | ' - THE FIRST ELEMENT THAT IS ADDED. WORKS FOR NOW, BUT NOT VERY DYNAMIC. 57 | ' 58 | ' - CURRENTLY HAVE A SLEEP HARDCODED, SHOULD LOOK INTO TESTING DIFFERENT THINGS TO SEE IF IT 59 | ' - CAN HELP REDUCE FLASHING. AGAIN, WORKS FOR NOW, BUT SHOULD BE A BETTER WAY. 60 | 61 | 'EXAMPLES (IN A USERFORM): 62 | ' 63 | ' 'SINGLE EFFECT 64 | ' Transition Effect(box, "left", 200, 300) 65 | ' 66 | ' 'MULTIPLE EFFECTS AT ONCE 67 | ' Transition Effect(sidebar, "width", 0, 500) _ 68 | ' , Effect(box, "Top", Me.InsideHeight - box.Height, 1000) _ 69 | ' , Effect(box2, "Top", 0, 100) _ 70 | ' , Effect(GoButton, "fontsize", 12, 1000) _ 71 | ' , Effect(me, "Top", 20, 2000) 72 | ' 73 | 74 | 75 | '****************************************************************************************** 76 | ' PUBLIC METHODS/FUNCTIONS 77 | '****************************************************************************************** 78 | Public Sub Transition(ParamArray Elements() As Variant) 79 | 80 | 'CAPTURE THE FORM 81 | Dim form As MSForms.UserForm 82 | Set form = Elements(LBound(Elements, 1))("form") 83 | 84 | MicroTimer True 85 | Do 86 | 87 | 'INCREMENT EACH ELEMENTS DESTINATION 88 | Dim Index As Integer 89 | For Index = LBound(Elements, 1) To UBound(Elements, 1) 90 | 91 | IncrementElement Elements(Index), MicroTimer 92 | 93 | Next Index 94 | 95 | 'SLEEP NEEDED TO SLOW DOWN THE FRAMERATE, OTHERWISE FLASHES A LOT 96 | Sleep 40 97 | form.Repaint 98 | 99 | 'CHECK TO SEE IF ALL ARE COMPLETE 100 | Loop Until AllTransitionsComplete(CVar(Elements)) 101 | 102 | End Sub 103 | 104 | Public Function Effect(obj As Object, Property As String, Destination As Double, MilSecs As Double) As Scripting.Dictionary 105 | 106 | Dim Temp As New Scripting.Dictionary 107 | 108 | Set Temp("obj") = obj 109 | Temp("property") = Property 110 | Temp("startValue") = CallByName(obj, Property, VbGet) 111 | Temp("destination") = Destination 112 | Temp("travel") = Destination - Temp("startValue") 113 | Temp("milSec") = MilSecs 114 | Temp("complete") = False 115 | 116 | On Error GoTo Catch: 117 | Set Temp("form") = obj.Parent 118 | 119 | Set Effect = Temp 120 | Exit Function 121 | Catch: 122 | Set Temp("form") = obj 123 | Resume Next 124 | 125 | End Function 126 | 127 | 128 | Public Function MicroTimer(Optional StartTime As Boolean = False) As Double 129 | 130 | ' uses Windows API calls to the high resolution timer 131 | Static dTime As Double 132 | 133 | Dim cyTicks1 As Currency 134 | Dim cyTicks2 As Currency 135 | Static cyFrequency As Currency 136 | 137 | MicroTimer = 0 138 | 139 | 'get frequency 140 | If cyFrequency = 0 Then getFrequency cyFrequency 141 | 142 | 'get ticks 143 | getTickCount cyTicks1 144 | getTickCount cyTicks2 145 | If cyTicks2 < cyTicks1 Then cyTicks2 = cyTicks1 146 | 147 | 'calc seconds 148 | If cyFrequency Then MicroTimer = cyTicks2 / cyFrequency 149 | 150 | If StartTime = True Then 151 | dTime = MicroTimer 152 | MicroTimer = 0 153 | Else 154 | MicroTimer = (MicroTimer - dTime) * 1000 'CONVERT TO MILSECS 155 | End If 156 | 157 | End Function 158 | 159 | '****************************************************************************************** 160 | ' PRIVATE METHODS/FUNCTIONS 161 | '****************************************************************************************** 162 | Private Function AllTransitionsComplete(Elements As Variant) As Boolean 163 | 164 | Dim El As Object 165 | Dim Index As Integer 166 | 167 | For Index = LBound(Elements, 1) To UBound(Elements, 1) 168 | 169 | Set El = Elements(Index) 170 | 171 | If Not TransitionComplete(El) Then 172 | AllTransitionsComplete = False 173 | Exit Function 174 | End If 175 | 176 | Next Index 177 | 178 | AllTransitionsComplete = True 179 | 180 | End Function 181 | 182 | Private Function TransitionComplete(ByVal El As Scripting.Dictionary) As Boolean 183 | 184 | If El("destination") = CallByName(El("obj"), El("property"), VbGet) Then 185 | TransitionComplete = True 186 | End If 187 | 188 | End Function 189 | 190 | Private Function IncrementElement(ByVal El As Scripting.Dictionary, CurrentTime As Double) As Boolean 191 | 192 | Dim IncrementValue As Double 193 | Dim CurrentValue As Double 194 | 195 | If TransitionComplete(El) Then 196 | Exit Function 197 | End If 198 | 199 | IncrementValue = easeInAndOut(CurrentTime, El("startValue"), El("travel"), El("milSec")) 200 | 201 | If El("travel") < 0 Then 202 | 203 | If Math.Round(IncrementValue, 4) < El("destination") Then 204 | CallByName El("obj"), El("property"), VbLet, El("destination") 205 | Else 206 | CallByName El("obj"), El("property"), VbLet, IncrementValue 207 | End If 208 | 209 | Else 210 | 211 | If Math.Round(IncrementValue, 4) > El("destination") Then 212 | CallByName El("obj"), El("property"), VbLet, El("destination") 213 | Else 214 | CallByName El("obj"), El("property"), VbLet, IncrementValue 215 | End If 216 | 217 | End If 218 | 219 | End Function 220 | 221 | 222 | '--legend 223 | '-b start value 224 | '-c DESTINATION - START 225 | '-d total time 226 | '-t current time (the only one that changes) 227 | Private Function easeInAndOut(ByVal t As Double, ByVal b As Double, ByVal c As Double, ByVal d As Double) As Double 228 | 229 | 'cubic 230 | d = d / 2 231 | t = t / d 232 | If (t < 1) Then 233 | easeInAndOut = c / 2 * t * t * t + b 234 | Else 235 | t = t - 2 236 | easeInAndOut = c / 2 * (t * t * t + 2) + b 237 | End If 238 | 239 | End Function 240 | 241 | 'Function easeInAndOut(ByVal t As Double, ByVal b As Double, ByVal c As Double, ByVal d As Double) As Double 242 | ' 243 | ' 'quartic 244 | ' d = d / 2 245 | ' t = t / d 246 | ' 247 | ' If (t < 1) Then 248 | ' easeInAndOut = c / 2 * t * t * t * t + b 249 | ' Else 250 | ' t = t - 2 251 | ' easeInAndOut = -c / 2 * (t * t * t * t - 2) + b 252 | ' End If 253 | ' 254 | ' 255 | 'End Function 256 | ' 257 | 'Function easeInAndOut3(ByVal t As Double, ByVal b As Double, ByVal c As Double, ByVal d As Double) As Double 258 | ' 259 | ' 'quintic 260 | ' d = d / 2 261 | ' t = t / d 262 | ' 263 | ' If (t < 1) Then 264 | ' easeInAndOut3 = c / 2 * t * t * t * t * t + b 265 | ' Else 266 | ' t = t - 2 267 | ' easeInAndOut3 = c / 2 * (t * t * t * t * t + 2) + b 268 | ' End If 269 | ' 270 | ' 271 | 'End Function 272 | ' 273 | 'Function easeInAndOut4(ByVal t As Double, ByVal b As Double, ByVal c As Double, ByVal d As Double) As Double 274 | ' 275 | ' 'sinusoidal 276 | ' easeInAndOut4 = -c / 2 * (Math.Cos(Application.WorksheetFunction.pi * t / d) - 1) + b 277 | ' 278 | ' 279 | 'End Function 280 | ' 281 | 'Function easeInAndOut5(ByVal t As Double, ByVal b As Double, ByVal c As Double, ByVal d As Double) As Double 282 | ' 283 | ' 'circular 284 | ' d = d / 2 285 | ' t = t / d 286 | ' 287 | ' If (t < 1) Then 288 | ' easeInAndOut5 = -c / 2 * (Math.Sqr(1 - t * t) - 1) + b 289 | ' Else 290 | ' t = t - 2 291 | ' easeInAndOut5 = c / 2 * (Math.Sqr(1 - t * t) + 1) + b 292 | ' End If 293 | ' 294 | 'End Function 295 | 296 | 297 | 'Function Bezier4(p1 As XYZ, p2 As XYZ, p3 As XYZ, p4 As XYZ, mu#) As XYZ 298 | '' Four control point Bezier interpolation 299 | '' mu ranges from 0 to 1, start to end of curve 300 | 'Dim mum1#, mum13#, mu3# 301 | 'Dim p As XYZ 302 | ' 303 | ' mum1 = 1 - mu 304 | ' mum13 = mum1 * mum1 * mum1 305 | ' mu3 = mu * mu * mu 306 | ' 307 | ' p.x = mum13 * p1.x + 3 * mu * mum1 * mum1 * p2.x + 3 * mu * mu * mum1 * p3.x + mu3 * p4.x 308 | ' p.y = mum13 * p1.y + 3 * mu * mum1 * mum1 * p2.y + 3 * mu * mu * mum1 * p3.y + mu3 * p4.y 309 | '' p.z = mum13 * p1.z + 3 * mu * mum1 * mum1 * p2.z + 3 * mu * mu * mum1 * p3.z + mu3 * p4.z 310 | ' 311 | ' Bezier4 = p 312 | 'End Function 313 | -------------------------------------------------------------------------------- /HandCursor.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/todar/VBA-Userform-Animations/c65ef7ea436f1f01a053d78bf65e38da2e5ff8ea/HandCursor.ico -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Robert Todar 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # VBA Userform Transitions and Animations 2 | Tools to have transitions and animations with Userforms and Userform controls 3 | Similar to CSS Transitions and Animations (kinda lol). 4 | 5 | ![](UserformAnimation.gif) 6 | 7 | # Usage 8 | ```vb 9 | 'EXAMPLE (IN A USERFORM WITH VARIOUS CONTROLS) 10 | Private Sub GoButton_Click() 11 | 12 | 'SINGLE EFFECT 13 | Transition Effect(sidebar, "width", 100, 1000) 14 | 15 | 'CAN ALSO DO EFFECTS ON USERFORMS 16 | Transition Effect(Me, "Top", 400, 1000) 17 | 18 | 'MULTIPLE EFFECTS APPLIED AT ONCE WITH DIFFERENT TIMES AND PROPERITES 19 | Transition Effect(sidebar, "width", 0, 500) _ 20 | , Effect(box, "Top", Me.InsideHeight - box.Height, 1000) _ 21 | , Effect(box2, "Top", 0, 500) _ 22 | , Effect(GoButton, "fontsize", 4, 1000) _ 23 | , Effect(Me, "Top", 100, 1000) _ 24 | 25 | 'MULTIPLE EFFECTS IN A ROW DO AN ANITMATION EFFECT 26 | Transition Effect(box, "Left", 0, 250), Effect(box, "Top", 0, 250) 27 | Transition Effect(box, "left", Me.InsideWidth - box.Width, 250) 28 | Transition Effect(box, "Top", Me.InsideHeight - box.Height, 250) 29 | Transition Effect(box, "left", 0, 250) 30 | Transition Effect(box, "Top", 0, 250) 31 | 32 | End Sub 33 | ``` 34 | 35 | 36 | # Public Methods/Functions 37 | - Transition 38 | - Effect 39 | - MicroTimer 40 | 41 | # Private Methods/Functions 42 | - AllTransitionsComplete 43 | - TransitionComplete 44 | - IncrementElement 45 | - easeInAndOut 46 | 47 | # TODO: 48 | - Change The Way That The Effect Is Called, That Way There Might Be An Option Of What Type Of Effect, Such As Liner, Ease-Out, Ease-In, Possibly Even Bezier Curve. 49 | 50 | - Need To Add A Function For Finding The Userform For Refresh, Currently Just Grabs It From The First Element That Is Added. Works For Now, But Not Very Dynamic. 51 | 52 | 53 | - Currently Have A Sleep Hardcoded, Should Look Into Testing Different Things To See If It can Help Reduce Flashing. Again, Works For Now, But Should Be A Better Way. 54 | 55 | 56 | -------------------------------------------------------------------------------- /UserformAnimation.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/todar/VBA-Userform-Animations/c65ef7ea436f1f01a053d78bf65e38da2e5ff8ea/UserformAnimation.gif -------------------------------------------------------------------------------- /animations.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/todar/VBA-Userform-Animations/c65ef7ea436f1f01a053d78bf65e38da2e5ff8ea/animations.xlsm --------------------------------------------------------------------------------