├── .github └── FUNDING.yml ├── src ├── ProgressForm.frx ├── Demo │ ├── DemoClass.cls │ └── Demo.bas ├── ProgressForm.frm └── ProgressBar.cls ├── .gitattributes ├── ExcelVBA ProgressBar_Demo.xlsm ├── LICENSE └── README.md /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: cristianbuse 2 | -------------------------------------------------------------------------------- /src/ProgressForm.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cristianbuse/Excel-VBA-ProgressBar/HEAD/src/ProgressForm.frx -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.bas -text linguist-language=VBA 2 | *.frm -text linguist-language=VBA 3 | *.cls -text linguist-language=VBA -------------------------------------------------------------------------------- /ExcelVBA ProgressBar_Demo.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cristianbuse/Excel-VBA-ProgressBar/HEAD/ExcelVBA ProgressBar_Demo.xlsm -------------------------------------------------------------------------------- /src/Demo/DemoClass.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "DemoClass" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | 12 | Public Function DoWork(ByVal progress As ProgressBar, ByRef stepCount As Variant) As Variant 13 | Dim i As Long 14 | For i = 1 To stepCount 15 | progress.Info2 = "Running " & i & " out of " & stepCount 16 | progress.Value = i / stepCount 17 | If progress.WasCancelled Then Exit Function 18 | Next 19 | DoWork = True 20 | End Function 21 | -------------------------------------------------------------------------------- /src/ProgressForm.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ProgressForm 3 | Caption = "UserForm1" 4 | ClientHeight = 1575 5 | ClientLeft = 120 6 | ClientTop = 465 7 | ClientWidth = 2835 8 | OleObjectBlob = "ProgressForm.frx":0000 9 | StartUpPosition = 1 'CenterOwner 10 | End 11 | Attribute VB_Name = "ProgressForm" 12 | Attribute VB_GlobalNameSpace = False 13 | Attribute VB_Creatable = False 14 | Attribute VB_PredeclaredId = True 15 | Attribute VB_Exposed = False 16 | 17 | Option Explicit 18 | 19 | Public Event Activate() 20 | Public Event QueryClose(Cancel As Integer, CloseMode As Integer) 21 | 22 | Private Sub UserForm_Activate() 23 | RaiseEvent Activate 24 | End Sub 25 | Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 26 | RaiseEvent QueryClose(Cancel, CloseMode) 27 | End Sub 28 | 29 | -------------------------------------------------------------------------------- /src/Demo/Demo.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Demo" 2 | Option Explicit 3 | 4 | Public Sub DemoMain() 5 | With New ProgressBar 6 | .Info1 = "Please wait..." 7 | .AllowCancel = True 8 | .BarColor = &H4D6A00 9 | .ShowTime = True 10 | .ShowType = vbModal 11 | Debug.Print .RunMacro(ThisWorkbook, "DoWork", .Self, 3000) 12 | .ShowType = vbModeless 13 | .ShowTime = False 14 | Debug.Print .RunObjMethod(New DemoClass, "DoWork", .Self, 2000) 15 | End With 16 | End Sub 17 | 18 | Public Function DoWork(ByVal progress As ProgressBar, ByRef stepCount As Long) As Boolean 19 | Dim i As Long 20 | For i = 1 To stepCount 21 | progress.Info2 = "Running " & i & " out of " & stepCount 22 | 'Do stuff here 23 | progress.Value = i / stepCount 24 | If progress.WasCancelled Then 25 | 'Clean-up code here 26 | Exit Function 27 | End If 28 | Next 29 | DoWork = True 30 | End Function 31 | 32 | 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Cristian Buse 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 | # Excel-VBA-ProgressBar 2 | Flexible Progress Bar for Excel 3 | 4 | ![gif](https://github.com/user-attachments/assets/1ce4af8b-5c16-4138-91d9-b91953fda97c) 5 | 6 | 7 | Related [Code Review question](https://codereview.stackexchange.com/questions/273741/progress-bar-for-excel) 8 | 9 | The Progress Bar from this project has the following features: 10 | - Works on both Windows and Mac 11 | - The user can cancel the displayed form via the X button (or the Esc key), if the ```AllowCancel``` property is set to ```True``` 12 | - The form displayed can be Modal but also Modeless, as needed (see ```ShowType ``` property) 13 | - The progress bar calls a 'worker' routine which: 14 | - can return a value if it's a ```Function``` 15 | - accepts a variable number of parameters and can change them ```ByRef``` if needed 16 | - can accept the progress bar instance at a specific position in the parameter list but not required 17 | - can be a macro in a workbook (see ```RunMacro``` ) or a method on an object (see ```RunObjMethod```) 18 | - Has the ability to show how much time has elapsed and an approximation of how much time is left if the ```ShowTime``` property is set to ```True``` 19 | - The userform module has a minimum of code (just events that are going to get raised) and has no design time controls which makes it easily reproducible 20 | 21 | ## Installation 22 | Just import the following code modules in your VBA Project: 23 | * [ProgressBar.cls](https://github.com/cristianbuse/Excel-VBA-ProgressBar/blob/master/src/ProgressBar.cls) 24 | * [ProgressForm.frm](https://github.com/cristianbuse/Excel-VBA-ProgressBar/blob/master/src/ProgressForm.frm) (you will also need the [ProgressForm.frx](https://github.com/cristianbuse/Excel-VBA-ProgressBar/blob/master/src/ProgressForm.frx) when you import) - Alternatively, this can be easily recreated from scratch in 3 easy steps: 25 | 1. insert new form 26 | 2. rename it to ```ProgressForm``` 27 | 3. add the following code: 28 | ```VBA 29 | Option Explicit 30 | 31 | Public Event Activate() 32 | Public Event QueryClose(Cancel As Integer, CloseMode As Integer) 33 | 34 | Private Sub UserForm_Activate() 35 | RaiseEvent Activate 36 | End Sub 37 | Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 38 | RaiseEvent QueryClose(Cancel, CloseMode) 39 | End Sub 40 | ``` 41 | 42 | ## Demo 43 | 44 | Import the following code modules: 45 | * [Demo.bas](https://github.com/cristianbuse/Excel-VBA-ProgressBar/blob/master/src/Demo/Demo.bas) - run ```DemoMain``` 46 | * [DemoClass.cls](https://github.com/cristianbuse/Excel-VBA-ProgressBar/blob/master/src/Demo/DemoClass.cls) 47 | 48 | There is also a Demo Workbook available for download. 49 | 50 | ## License 51 | MIT License 52 | 53 | Copyright (c) 2022 Ion Cristian Buse 54 | 55 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 56 | 57 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 58 | 59 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 60 | -------------------------------------------------------------------------------- /src/ProgressBar.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "ProgressBar" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | '''============================================================================= 11 | ''' VBA ProgressBar for Excel 12 | ''' ----------------------------------------------------- 13 | ''' https://github.com/cristianbuse/Excel-VBA-ProgressBar 14 | ''' ----------------------------------------------------- 15 | ''' MIT License 16 | ''' 17 | ''' Copyright (c) 2022 Ion Cristian Buse 18 | ''' 19 | ''' Permission is hereby granted, free of charge, to any person obtaining a copy 20 | ''' of this software and associated documentation files (the "Software"), to 21 | ''' deal in the Software without restriction, including without limitation the 22 | ''' rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 23 | ''' sell copies of the Software, and to permit persons to whom the Software is 24 | ''' furnished to do so, subject to the following conditions: 25 | ''' 26 | ''' The above copyright notice and this permission notice shall be included in 27 | ''' all copies or substantial portions of the Software. 28 | ''' 29 | ''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 30 | ''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 31 | ''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 32 | ''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 33 | ''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 34 | ''' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 35 | ''' IN THE SOFTWARE. 36 | '''============================================================================= 37 | 38 | Option Explicit 39 | 40 | #If Mac Then 41 | #If VBA7 Then 42 | Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr 43 | #Else 44 | Private Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long 45 | #End If 46 | #Else 'Windows 47 | 'https://msdn.microsoft.com/en-us/library/mt723419(v=vs.85).aspx 48 | #If VBA7 Then 49 | Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr) 50 | #Else 51 | Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) 52 | #End If 53 | #End If 54 | 55 | Private WithEvents m_form As ProgressForm 56 | Attribute m_form.VB_VarHelpID = -1 57 | Private m_allowCancel As Boolean 58 | Private m_cancelled As Boolean 59 | Private m_currentValue As Double 60 | Private m_isAutoCentered As Boolean 61 | Private m_isRunning As Boolean 62 | Private m_procedure As String 63 | Private m_result As Variant 64 | Private m_showTime As Boolean 65 | Private m_showType As FormShowConstants 66 | Private m_startTime As Date 67 | Private m_targetBook As Workbook 68 | Private m_targetObj As Object 69 | Private m_args() As Variant 70 | 71 | 'Controls 72 | Private m_info1 As MSForms.Label 73 | Private m_info2 As MSForms.Label 74 | Private m_barFrame As MSForms.Frame 75 | Private m_bar As MSForms.Label 76 | Private m_elapsed As MSForms.Label 77 | Private m_remaining As MSForms.Label 78 | Private m_percent As MSForms.Label 79 | Private WithEvents m_escButton As MSForms.CommandButton 80 | Attribute m_escButton.VB_VarHelpID = -1 81 | 82 | #If Mac Then 83 | #ElseIf VBA7 Then 84 | Private Declare PtrSafe _ 85 | Function rtcCallByName Lib "VBE7.DLL" (ByVal targetObj As Object _ 86 | , ByVal procNamePtr As LongPtr _ 87 | , ByVal vCallType As VbCallType _ 88 | , ByRef args() As Any _ 89 | , Optional ByVal lcid As Long) As Variant 90 | #Else 91 | Private Declare _ 92 | Function rtcCallByName Lib "msvbvm60" (ByVal targetObj As Object _ 93 | , ByVal procNamePtr As Long _ 94 | , ByVal vCallType As VbCallType _ 95 | , ByRef args() As Any _ 96 | , Optional ByVal lcid As Long) As Variant 97 | #End If 98 | 99 | '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 100 | 'Class events 101 | '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 102 | Private Sub Class_Initialize() 103 | Set m_form = New ProgressForm 104 | BuildForm 105 | With Me 106 | .AllowCancel = False 107 | .Caption = "Progress..." 108 | .Info1 = "Please wait..." 109 | .Info2 = vbNullString 110 | .ShowTime = False 111 | .ShowType = vbModal 112 | .CenterOnApplication 113 | End With 114 | End Sub 115 | Private Sub Class_Terminate() 116 | TryHideForm 117 | Set m_form = Nothing 118 | End Sub 119 | Private Sub TryHideForm() 120 | On Error Resume Next 'Avoid error 402 121 | m_form.Hide 122 | On Error GoTo 0 123 | End Sub 124 | 125 | '******************************************************************************* 126 | 'Builds the necessary controls and alignment at runtime 127 | '******************************************************************************* 128 | Private Sub BuildForm() 129 | Const progIDLabel As String = "Forms.Label.1" 130 | Const progIDFrame As String = "Forms.Frame.1" 131 | Const progIDButton As String = "Forms.CommandButton.1" 132 | Const sideValue As Single = 6 133 | ' 134 | m_form.Font.Name = "Tahoma" 135 | m_form.Font.Size = 8.25 136 | m_form.Width = 300 137 | ' 138 | Set m_info1 = m_form.Controls.Add(progIDLabel) 139 | CastToControl(m_info1).Move sideValue, sideValue 140 | TextAlignLabel m_info1, False, True, fmTextAlignLeft 141 | ' 142 | Set m_info2 = m_form.Controls.Add(progIDLabel) 143 | CastToControl(m_info2).Move sideValue, CastToControl(m_info1).Top + 12 144 | TextAlignLabel m_info2, False, True, fmTextAlignLeft 145 | ' 146 | Set m_barFrame = m_form.Controls.Add(progIDFrame) 147 | CastToControl(m_barFrame).Move sideValue, CastToControl(m_info2).Top + 15 _ 148 | , m_form.InsideWidth - sideValue * 2, 15 149 | m_barFrame.SpecialEffect = fmSpecialEffectSunken 150 | ' 151 | Set m_bar = m_barFrame.Controls.Add(progIDLabel) 152 | CastToControl(m_bar).Move 0, 0, 15, 15 153 | m_bar.BackColor = &HC07000 154 | ' 155 | Set m_elapsed = m_form.Controls.Add(progIDLabel) 156 | CastToControl(m_elapsed).Move sideValue, CastToControl(m_barFrame).Top + 18 157 | TextAlignLabel m_elapsed, False, True, fmTextAlignLeft 158 | ' 159 | Set m_remaining = m_form.Controls.Add(progIDLabel) 160 | CastToControl(m_remaining).Move sideValue, CastToControl(m_elapsed).Top + 12 161 | TextAlignLabel m_remaining, False, True, fmTextAlignLeft 162 | m_form.Height = CastToControl(m_remaining).Top + sideValue 163 | With m_form 164 | .Height = .Height * 2 - .InsideHeight 165 | End With 166 | ' 167 | Set m_percent = m_form.Controls.Add(progIDLabel) 168 | CastToControl(m_percent).Move CastToControl(m_barFrame).Width _ 169 | + sideValue - 60, CastToControl(m_elapsed).Top, 60 170 | TextAlignLabel m_percent, False, False, fmTextAlignRight 171 | ' 172 | Set m_escButton = m_form.Controls.Add(progIDButton) 173 | With CastToControl(m_escButton) 174 | .Cancel = True 'Allows for the form to be closed by pressing the Esc key 175 | .Move 0, 0, 0, 0 176 | End With 177 | End Sub 178 | Private Function CastToControl(ByVal c As MSForms.Control) As MSForms.Control 179 | Set CastToControl = c 180 | End Function 181 | Private Sub TextAlignLabel(ByVal labelControl As MSForms.Label _ 182 | , ByVal wordWrapValue As Boolean _ 183 | , ByVal autoSizeValue As Boolean _ 184 | , ByVal textAlignValue As fmTextAlign) 185 | With labelControl 186 | .WordWrap = wordWrapValue 187 | .AutoSize = autoSizeValue 188 | .TextAlign = textAlignValue 189 | End With 190 | End Sub 191 | 192 | '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 193 | 'Form/Control events 194 | '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 195 | Private Sub m_form_Activate() 196 | If m_showType = vbModal Then RunProcedure 197 | End Sub 198 | Private Sub m_form_QueryClose(Cancel As Integer, CloseMode As Integer) 199 | If CloseMode = VbQueryClose.vbFormControlMenu Then 'User pressed X button 200 | Cancel = True 201 | OnCancel 202 | End If 203 | End Sub 204 | Private Sub m_escButton_Click() 205 | OnCancel 206 | End Sub 207 | Private Sub OnCancel() 208 | If Not m_allowCancel Then Exit Sub 209 | ' 210 | If MsgBox(Prompt:="Are you sure you want to cancel?" _ 211 | , Buttons:=vbQuestion + vbYesNo _ 212 | , Title:="Please confirm" _ 213 | ) = vbYes Then 214 | m_form.Hide 215 | m_cancelled = True 216 | End If 217 | End Sub 218 | 219 | '=============================================================================== 220 | 'Caption text 221 | '=============================================================================== 222 | Public Property Get Caption() As String 223 | Caption = m_form.Caption 224 | End Property 225 | Public Property Let Caption(ByVal formCaption As String) 226 | m_form.Caption = formCaption 227 | Refresh 228 | End Property 229 | 230 | '=============================================================================== 231 | 'Info1 text 232 | '=============================================================================== 233 | Public Property Get Info1() As String 234 | Info1 = m_info1.Caption 235 | End Property 236 | Public Property Let Info1(ByVal info1Label As String) 237 | m_info1.Caption = info1Label 238 | Refresh 239 | End Property 240 | 241 | '=============================================================================== 242 | 'Info2 text 243 | '=============================================================================== 244 | Public Property Get Info2() As String 245 | Info2 = m_info2.Caption 246 | End Property 247 | Public Property Let Info2(ByVal info2Label As String) 248 | m_info2.Caption = info2Label 249 | Refresh 250 | End Property 251 | 252 | '=============================================================================== 253 | 'Color of the bar 254 | '=============================================================================== 255 | Public Property Get BarColor() As Long 256 | BarColor = m_bar.BackColor 257 | End Property 258 | Public Property Let BarColor(ByVal colorCode As Long) 259 | m_bar.BackColor = colorCode 260 | Refresh 261 | End Property 262 | 263 | '=============================================================================== 264 | 'Color of the frame (bar background) 265 | '=============================================================================== 266 | Public Property Get BarBackColor() As Long 267 | BarBackColor = m_barFrame.BackColor 268 | End Property 269 | Public Property Let BarBackColor(ByVal colorCode As Long) 270 | m_barFrame.BackColor = colorCode 271 | Refresh 272 | End Property 273 | 274 | '=============================================================================== 275 | 'Enables/disables the X button on the progress form 276 | '=============================================================================== 277 | Public Property Get AllowCancel() As Boolean 278 | AllowCancel = m_allowCancel 279 | End Property 280 | Public Property Let AllowCancel(ByVal canCancel As Boolean) 281 | m_allowCancel = canCancel 282 | End Property 283 | 284 | '=============================================================================== 285 | 'Can be modal or modeless 286 | '=============================================================================== 287 | Public Property Get ShowType() As FormShowConstants 288 | ShowType = m_showType 289 | End Property 290 | Public Property Let ShowType(ByVal formShowType As FormShowConstants) 291 | If formShowType <> vbModal Then formShowType = vbModeless 'Restrict value 292 | m_showType = formShowType 293 | End Property 294 | 295 | '=============================================================================== 296 | 'Enables/disables the time labels 297 | '=============================================================================== 298 | Public Property Get ShowTime() As Boolean 299 | ShowTime = m_showTime 300 | End Property 301 | Public Property Let ShowTime(ByVal displayTime As Boolean) 302 | If m_showTime Xor displayTime Then 303 | Dim adjustment As Single: adjustment = CastToControl(m_remaining).Height 304 | If Not displayTime Then adjustment = -adjustment 305 | m_form.Height = m_form.Height + adjustment 306 | End If 307 | m_showTime = displayTime 308 | m_elapsed.Visible = m_showTime 309 | m_remaining.Visible = m_showTime 310 | Refresh 311 | End Property 312 | 313 | '=============================================================================== 314 | 'Indicates if the X button on the progress form was pressed 315 | '=============================================================================== 316 | Public Property Get WasCancelled() As Boolean 317 | WasCancelled = m_cancelled 318 | End Property 319 | 320 | '=============================================================================== 321 | 'Vertical position 322 | '=============================================================================== 323 | Public Property Get Top() As Single 324 | Top = m_form.Top 325 | End Property 326 | Public Property Let Top(ByVal topValue As Single) 327 | m_form.Top = topValue 328 | m_isAutoCentered = False 329 | End Property 330 | 331 | '=============================================================================== 332 | 'Horizontal position 333 | '=============================================================================== 334 | Public Property Get Left() As Single 335 | Left = m_form.Left 336 | End Property 337 | Public Property Let Left(ByVal leftValue As Single) 338 | m_form.Left = leftValue 339 | m_isAutoCentered = False 340 | End Property 341 | 342 | '******************************************************************************* 343 | 'Utility for positioning 344 | '******************************************************************************* 345 | Public Sub CenterOnApplication() 346 | If Application.WindowState = xlMinimized Then Exit Sub 347 | If ThisWorkbook.Windows.Count > 0 Then 348 | If ThisWorkbook.Windows(1).WindowState = xlMinimized Then Exit Sub 349 | End If 350 | ' 351 | Dim leftPosition As Single 352 | Dim topPosition As Single 353 | ' 354 | With Application 355 | leftPosition = .Left + (.Width - m_form.Width) / 2 356 | If leftPosition < .Left Then leftPosition = .Left 357 | ' 358 | topPosition = .Top + (.Height - m_form.Height) / 2 359 | If topPosition < .Top Then topPosition = .Top 360 | End With 361 | With m_form 362 | .StartUpPosition = 0 363 | .Left = leftPosition 364 | .Top = topPosition 365 | End With 366 | m_isAutoCentered = True 367 | End Sub 368 | 369 | '=============================================================================== 370 | 'Size 371 | '=============================================================================== 372 | Public Property Get Height() As Single 373 | Height = m_form.Height 374 | End Property 375 | Public Property Get Width() As Single 376 | Width = m_form.Width 377 | End Property 378 | Public Property Let Width(ByVal widthValue As Single) 379 | Const minWidth As Single = 180 380 | Const maxWidth As Single = 450 381 | Dim finalWidth As Single: finalWidth = widthValue 382 | Dim offsetValue As Single 383 | ' 384 | If finalWidth < minWidth Then finalWidth = minWidth 385 | If finalWidth > maxWidth Then finalWidth = maxWidth 386 | If finalWidth = m_form.Width Then Exit Property 387 | offsetValue = finalWidth - m_form.Width 388 | ' 389 | m_form.Width = finalWidth 390 | m_barFrame.Width = m_barFrame.Width + offsetValue 391 | m_percent.Left = m_percent.Left + offsetValue 392 | If m_isAutoCentered Then m_form.Left = m_form.Left - offsetValue / 2 393 | End Property 394 | 395 | '******************************************************************************* 396 | 'Self-instance 397 | '******************************************************************************* 398 | Public Function Self() As ProgressBar 399 | Set Self = Me 400 | End Function 401 | 402 | '=============================================================================== 403 | 'Current progress value 404 | '=============================================================================== 405 | Public Property Get Value() As Double 406 | Value = m_currentValue 407 | End Property 408 | Public Property Let Value(ByVal percentValue As Double) 409 | If percentValue < 0 Or percentValue > 1 Then Exit Property 410 | m_currentValue = percentValue 411 | ' 412 | m_bar.Width = m_currentValue * m_barFrame.InsideWidth 413 | m_percent.Caption = "Done: " & Format$(m_currentValue, "0%") 414 | ' 415 | Refresh 416 | End Property 417 | 418 | '******************************************************************************* 419 | 'Updates the time and allows for events so that the form is updated visually 420 | '******************************************************************************* 421 | Private Sub Refresh() 422 | If m_isRunning Then 423 | UpdateTime 424 | DoEvents 425 | End If 426 | End Sub 427 | Private Sub UpdateTime() 428 | If Not m_showTime Then Exit Sub 429 | If m_currentValue = 0 Then 430 | m_elapsed.Caption = vbNullString 431 | m_remaining.Caption = vbNullString 432 | Exit Sub 433 | End If 434 | ' 435 | Dim elapsedTime As Date 436 | Dim remainingTime As Date 437 | ' 438 | elapsedTime = VBA.Now - m_startTime 439 | remainingTime = elapsedTime / m_currentValue * (1 - m_currentValue) 440 | ' 441 | UpdateTimeLabel m_elapsed, elapsedTime, "Elapsed time: " 442 | UpdateTimeLabel m_remaining, remainingTime, "Remaining time: " 443 | End Sub 444 | Private Sub UpdateTimeLabel(ByVal labelControl As MSForms.Label _ 445 | , ByVal timeValue As Date _ 446 | , ByVal prefix As String) 447 | Dim labelValue As String: labelValue = prefix 448 | If timeValue > 1 Then labelValue = labelValue & Int(CDbl(timeValue)) & "d " 449 | labelControl.Caption = labelValue & Format$(timeValue, "hh:mm:ss") 450 | End Sub 451 | 452 | '******************************************************************************* 453 | 'Runs a macro in a standard module 454 | '******************************************************************************* 455 | Public Function RunMacro(ByVal targetBook As Workbook _ 456 | , ByVal procedure As String _ 457 | , ParamArray args() As Variant) As Variant 458 | If m_isRunning Then Exit Function 459 | Dim methodName As String: methodName = TypeName(Me) & ".RunMacro" 460 | ' 461 | If procedure = vbNullString Then 462 | Err.Raise 5, methodName, "Invalid procedure name" 463 | ElseIf targetBook Is Nothing Then 464 | Err.Raise 91, methodName, "Workbook not set" 465 | ElseIf UBound(args) >= LBound(args) Then 'Save arguments for async use 466 | CloneParamArray Not Not args, m_args 'ByRef is preserved! 467 | Else 468 | m_args = Array() 469 | End If 470 | ' 471 | LetSet(RunMacro) = Run(procedure, targetBook, Nothing) 472 | End Function 473 | 474 | '******************************************************************************* 475 | 'Runs a method of a given object 476 | '******************************************************************************* 477 | Public Function RunObjMethod(ByVal targetObject As Object _ 478 | , ByVal procedure As String _ 479 | , ParamArray args() As Variant) As Variant 480 | If m_isRunning Then Exit Function 481 | Dim methodName As String: methodName = TypeName(Me) & ".RunObjMethod" 482 | ' 483 | If procedure = vbNullString Then 484 | Err.Raise 5, methodName, "Invalid procedure name" 485 | ElseIf targetObject Is Nothing Then 486 | Err.Raise 91, methodName, "Object not set" 487 | ElseIf UBound(args) >= LBound(args) Then 'Save arguments for async use 488 | CloneParamArray Not Not args, m_args 'ByRef is preserved! 489 | Else 490 | m_args = Array() 491 | End If 492 | ' 493 | LetSet(RunObjMethod) = Run(procedure, Nothing, targetObject) 494 | End Function 495 | 496 | '******************************************************************************* 497 | 'Copy a param array to another array of Variants while preserving ByRef elements 498 | 'If the paramarray name is 'args' then the call needs to look like this: 499 | ' CloneParamArray Not Not args, outArray 500 | '******************************************************************************* 501 | Private Sub CloneParamArray(ByVal paramPtr As LongPtr, ByRef out() As Variant) 502 | Dim v As Variant: v = paramPtr 503 | CopyMemory ByVal VarPtr(v), vbArray + vbVariant, 2 504 | out = v 505 | CopyMemory ByVal VarPtr(v), vbEmpty, 2 506 | End Sub 507 | 508 | '******************************************************************************* 509 | 'Runs a method: 510 | ' - in a standard module if 'targetBook' is provided 511 | ' - on an object if 'targetObject' is provided 512 | '******************************************************************************* 513 | Private Function Run(ByVal procedure As String _ 514 | , ByVal targetBook As Workbook _ 515 | , ByVal targetObject As Object) As Variant 516 | m_procedure = procedure 517 | Set m_targetBook = targetBook 518 | Set m_targetObj = targetObject 519 | ' 520 | m_isRunning = True 521 | m_cancelled = False 522 | Value = 0 523 | ' 524 | m_form.Show m_showType 525 | If m_showType = vbModeless Then 526 | RunProcedure 527 | Else 'vbModal. RunProcedure was already executed via Form_Activate event 528 | End If 529 | LetSet(Run) = m_result 530 | End Function 531 | 532 | '******************************************************************************* 533 | 'Utility - assigns a variant to another variant 534 | '******************************************************************************* 535 | Private Property Let LetSet(ByRef result As Variant, ByRef v As Variant) 536 | If IsObject(v) Then Set result = v Else result = v 537 | End Property 538 | 539 | '******************************************************************************* 540 | 'Runs the actual method 541 | '******************************************************************************* 542 | Private Sub RunProcedure() 543 | m_startTime = Now() 544 | ' 545 | Dim cKey As XlEnableCancelKey: cKey = Application.EnableCancelKey 546 | If cKey <> xlDisabled Then Application.EnableCancelKey = xlDisabled 547 | ' 548 | On Error GoTo Clean 549 | If m_targetObj Is Nothing Then 550 | RunOnBook 551 | Else 552 | #If Mac Then 553 | RunOnObject m_args 554 | #Else 555 | LetSet(m_result) = rtcCallByName(targetObj:=m_targetObj _ 556 | , procNamePtr:=StrPtr(m_procedure) _ 557 | , vCallType:=VbMethod _ 558 | , args:=m_args) 559 | #End If 560 | End If 561 | Clean: 562 | If cKey <> xlDisabled Then Application.EnableCancelKey = cKey 563 | m_isRunning = False 564 | If Err.Number = 0 Then 565 | TryHideForm 'Protection if multiple progress bars are displayed 566 | Else 567 | m_form.Hide 568 | Err.Raise Err.Number, TypeName(Me) & ".RunProcedure" 569 | End If 570 | End Sub 571 | Private Sub RunOnBook(Optional ByVal Missing As Variant) 572 | Const maxRunArgs As Long = 30 573 | Dim argsCount As Long: argsCount = UBound(m_args) + 1 574 | Dim i As Long 575 | ' 576 | ReDim Preserve m_args(0 To maxRunArgs - 1) 577 | For i = argsCount To UBound(m_args) 578 | m_args(i) = Missing 579 | Next i 580 | ' 581 | LetSet(m_result) = Application.Run(FullProcedureName() _ 582 | , m_args(0), m_args(1), m_args(2), m_args(3), m_args(4) _ 583 | , m_args(5), m_args(6), m_args(7), m_args(8), m_args(9) _ 584 | , m_args(10), m_args(11), m_args(12), m_args(13), m_args(14) _ 585 | , m_args(15), m_args(16), m_args(17), m_args(18), m_args(19) _ 586 | , m_args(20), m_args(21), m_args(22), m_args(23), m_args(24) _ 587 | , m_args(25), m_args(26), m_args(27), m_args(28), m_args(29)) 588 | End Sub 589 | Private Function FullProcedureName() As String 590 | If m_targetBook Is ThisWorkbook Then 'No need to qualify book. Default is always ThisWB 591 | FullProcedureName = m_procedure 592 | Else 593 | FullProcedureName = "'" & Replace(m_targetBook.Name, "'", "''") & "'!" & m_procedure 594 | End If 595 | End Function 596 | #If Mac Then 597 | Private Sub RunOnObject(ByRef args() As Variant) 598 | Dim o As Object: Set o = m_targetObj 599 | Dim p As String: p = m_procedure 600 | Dim v As VbCallType: v = VbMethod 601 | ' 602 | Select Case UBound(args) - LBound(args) + 1 603 | Case 0: LetSet(m_result) = CallByName(o, p, v) 604 | Case 1: LetSet(m_result) = CallByName(o, p, v, args(0)) 605 | Case 2: LetSet(m_result) = CallByName(o, p, v, args(0), args(1)) 606 | Case 3: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2)) 607 | Case 4: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3)) 608 | Case 5: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4)) 609 | Case 6: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5)) 610 | Case 7: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6)) 611 | Case 8: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7)) 612 | Case 9: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8)) 613 | Case 10: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9)) 614 | Case 11: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10)) 615 | Case 12: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11)) 616 | Case 13: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12)) 617 | Case 14: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13)) 618 | Case 15: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14)) 619 | Case 16: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15)) 620 | Case 17: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16)) 621 | Case 18: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17)) 622 | Case 19: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18)) 623 | Case 20: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19)) 624 | Case 21: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20)) 625 | Case 22: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21)) 626 | Case 23: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22)) 627 | Case 24: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23)) 628 | Case 25: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23), args(24)) 629 | Case 26: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23), args(24), args(25)) 630 | Case 27: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23), args(24), args(25), args(26)) 631 | Case 28: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23), args(24), args(25), args(26), args(27)) 632 | Case 29: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23), args(24), args(25), args(26), args(27), args(28)) 633 | Case Else: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23), args(24), args(25), args(26), args(27), args(28), args(29)) 634 | End Select 635 | End Sub 636 | #End If 637 | --------------------------------------------------------------------------------