├── .gitignore ├── LICENSE ├── README.md ├── images ├── sample-form-after.png └── sample-form-before.png ├── other-office-product-tests ├── excel-form-moderniser-test.xlsm └── word-form-moderniser-test.docm ├── vba-form-moderniser.pptm └── vba-form-moderniser.src ├── CKeyDownResponder.cls ├── CLabelControl.cls ├── CLabelControlFrameResponder.cls ├── CLabelControlResponder.cls ├── CLabelControls.cls ├── CLabelControlsManager.cls ├── FormModerniserDevPPT.bas ├── FormModerniserDevUtility.bas ├── FormModerniserDevWord.bas ├── FormModerniserModule.bas ├── MainModule.bas ├── USampleUserForm.frm ├── USampleUserForm.frx ├── USampleUserFormOldStyle.frm ├── USampleUserFormOldStyle.frx ├── VFMFactory.bas └── VFMUtility.bas /.gitignore: -------------------------------------------------------------------------------- 1 | ~$* 2 | *.bak 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Commtap CIC 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 Form Moderniser 2 | Sets up modern buttons based on userform labels and styles other elements in Office VBA userforms. 3 | This gives vba userforms a look close to that of modern office forms. 4 | 5 | ## Before and after 6 | 7 | Makes it easy to turn a VBA userform from this: 8 | 9 | ![Form before](https://github.com/neilt1700/vba-form-moderniser/blob/master/images/sample-form-before.png) 10 | 11 | To this: 12 | 13 | ![Form before](https://github.com/neilt1700/vba-form-moderniser/blob/master/images/sample-form-after.png) 14 | 15 | ## Summary of what it does 16 | * Creates modern style buttons by converting command buttons into layers of labels. 17 | * Applies general styles to the VBA Userform (as far as that is possible). 18 | * Allows you to use the keyboard to move into the new controls (you need at least one element on your form which can handle keydown events for this to work). 19 | 20 | ## How to use 21 | You can just download and take a look at [vba-form-moderniser.pptm](https://github.com/neilt1700/vba-form-moderniser/releases). There is a sample form in there and that's called from the MainModule. There is a small amount of extra code you will need to add to your forms as shown in the sample. [Full details are in the Wiki](https://github.com/neilt1700/vba-form-moderniser/wiki/How-to-use-the-VBA-Form-Moderniser). 22 | 23 | This now converts command buttons directly. 24 | 25 | ## How it works in more detail 26 | The code picks up all command buttons on a form and uses them to create the label controls. Each control is made up of a border layer, background layer, text layer (having the caption from the original command button), and on top, a transparent control layer which receives mouse events and calls the Click method for the original command button (which is now hidden). Mouse up/down/move events are used to control the look of the buttons. 27 | 28 | ## Office Programmes 29 | While the code is in a PowerPoint file it should work in other Office programmes including Excel and Word. The colour scheme for form controls that appear in the workspace of all these programmes is the same (blue). 30 | -------------------------------------------------------------------------------- /images/sample-form-after.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/neilt1700/vba-form-moderniser/c5dfd863541325ed5b75dcfaae0e19037bfdecc6/images/sample-form-after.png -------------------------------------------------------------------------------- /images/sample-form-before.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/neilt1700/vba-form-moderniser/c5dfd863541325ed5b75dcfaae0e19037bfdecc6/images/sample-form-before.png -------------------------------------------------------------------------------- /other-office-product-tests/excel-form-moderniser-test.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/neilt1700/vba-form-moderniser/c5dfd863541325ed5b75dcfaae0e19037bfdecc6/other-office-product-tests/excel-form-moderniser-test.xlsm -------------------------------------------------------------------------------- /other-office-product-tests/word-form-moderniser-test.docm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/neilt1700/vba-form-moderniser/c5dfd863541325ed5b75dcfaae0e19037bfdecc6/other-office-product-tests/word-form-moderniser-test.docm -------------------------------------------------------------------------------- /vba-form-moderniser.pptm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/neilt1700/vba-form-moderniser/c5dfd863541325ed5b75dcfaae0e19037bfdecc6/vba-form-moderniser.pptm -------------------------------------------------------------------------------- /vba-form-moderniser.src/CKeyDownResponder.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "CKeyDownResponder" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | ' Copyright (c) Commtap CIC 2019 11 | ' Available under the MIT license: see the LICENSE file at the root of this 12 | ' project. 13 | ' Contact: tap@commtap.org 14 | 15 | Option Explicit 16 | 17 | Private Const msMODULE As String = "CKeyDownResponder" 18 | 19 | Public WithEvents OptionButtonEvents As MSForms.OptionButton 20 | Attribute OptionButtonEvents.VB_VarHelpID = -1 21 | Public WithEvents ScrollBarEvents As MSForms.ScrollBar 22 | Attribute ScrollBarEvents.VB_VarHelpID = -1 23 | Public WithEvents SpinButtonEvents As MSForms.SpinButton 24 | Attribute SpinButtonEvents.VB_VarHelpID = -1 25 | Public WithEvents ListBoxEvents As MSForms.ListBox 26 | Attribute ListBoxEvents.VB_VarHelpID = -1 27 | Public WithEvents TabStripEvents As MSForms.TabStrip 28 | Attribute TabStripEvents.VB_VarHelpID = -1 29 | Public WithEvents CheckBoxEvents As MSForms.CheckBox 30 | Attribute CheckBoxEvents.VB_VarHelpID = -1 31 | Public WithEvents TextBoxEvents As MSForms.TextBox 32 | Attribute TextBoxEvents.VB_VarHelpID = -1 33 | 34 | Private p_ctlControl As Control 35 | Private p_oLabelControls As CLabelControls 36 | Private p_ctlsControls As Controls 37 | 38 | Private Sub OptionButtonEvents_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 39 | 40 | Const sSOURCE As String = "OptionButtonEvents_KeyDown" 41 | On Error GoTo ErrorHandler 42 | 43 | MyEventsKeyDown KeyCode, Shift 44 | 45 | ErrorExit: 46 | Exit Sub 47 | 48 | ErrorHandler: 49 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 50 | Stop 51 | Resume 52 | Else 53 | Resume ErrorExit 54 | End If 55 | 56 | End Sub 57 | 58 | Private Sub OptionButtonEvents_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 59 | 60 | Const sSOURCE As String = "OptionButtonEvents_MouseDown" 61 | On Error GoTo ErrorHandler 62 | 63 | MyEventsMouseDown Button, Shift, X, Y 64 | 65 | ErrorExit: 66 | Exit Sub 67 | 68 | ErrorHandler: 69 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 70 | Stop 71 | Resume 72 | Else 73 | Resume ErrorExit 74 | End If 75 | 76 | End Sub 77 | 78 | Private Sub ScrollBarEvents_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 79 | 80 | Const sSOURCE As String = "ScrollBarEvents_KeyDown" 81 | On Error GoTo ErrorHandler 82 | 83 | MyEventsKeyDown KeyCode, Shift 84 | 85 | ErrorExit: 86 | Exit Sub 87 | 88 | ErrorHandler: 89 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 90 | Stop 91 | Resume 92 | Else 93 | Resume ErrorExit 94 | End If 95 | 96 | End Sub 97 | 98 | 'No mousedown event for scrollbar events. 99 | 'Private Sub ScrollBarEvents_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 100 | ' MyEventsMouseDown Button, Shift, X, Y 101 | 'End Sub 102 | 103 | Private Sub SpinButtonEvents_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 104 | 105 | Const sSOURCE As String = "SpinButtonEvents_KeyDown" 106 | On Error GoTo ErrorHandler 107 | 108 | MyEventsKeyDown KeyCode, Shift 109 | 110 | ErrorExit: 111 | Exit Sub 112 | 113 | ErrorHandler: 114 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 115 | Stop 116 | Resume 117 | Else 118 | Resume ErrorExit 119 | End If 120 | 121 | End Sub 122 | 123 | 'No mousedown event for spinbutton events. 124 | 'Private Sub SpinButtonEvents_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 125 | ' MyEventsMouseDown Button, Shift, X, Y 126 | 'End Sub 127 | 128 | Private Sub ListBoxEvents_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 129 | 130 | Const sSOURCE As String = "ListBoxEvents_KeyDown" 131 | On Error GoTo ErrorHandler 132 | 133 | MyEventsKeyDown KeyCode, Shift 134 | 135 | ErrorExit: 136 | Exit Sub 137 | 138 | ErrorHandler: 139 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 140 | Stop 141 | Resume 142 | Else 143 | Resume ErrorExit 144 | End If 145 | 146 | End Sub 147 | 148 | Private Sub ListBoxEvents_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 149 | 150 | Const sSOURCE As String = "ListBoxEvents_MouseDown" 151 | On Error GoTo ErrorHandler 152 | 153 | MyEventsMouseDown Button, Shift, X, Y 154 | 155 | ErrorExit: 156 | Exit Sub 157 | 158 | ErrorHandler: 159 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 160 | Stop 161 | Resume 162 | Else 163 | Resume ErrorExit 164 | End If 165 | 166 | End Sub 167 | 168 | Private Sub TabStripEvents_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 169 | 170 | Const sSOURCE As String = "TabStripEvents_KeyDown" 171 | On Error GoTo ErrorHandler 172 | 173 | MyEventsKeyDown KeyCode, Shift 174 | 175 | ErrorExit: 176 | Exit Sub 177 | 178 | ErrorHandler: 179 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 180 | Stop 181 | Resume 182 | Else 183 | Resume ErrorExit 184 | End If 185 | 186 | End Sub 187 | 188 | Private Sub TabStripEvents_MouseDown(ByVal Index As Long, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 189 | 190 | Const sSOURCE As String = "TabStripEvents_MouseDown" 191 | On Error GoTo ErrorHandler 192 | 193 | MyEventsMouseDown Button, Shift, X, Y 194 | 195 | ErrorExit: 196 | Exit Sub 197 | 198 | ErrorHandler: 199 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 200 | Stop 201 | Resume 202 | Else 203 | Resume ErrorExit 204 | End If 205 | 206 | End Sub 207 | 208 | Private Sub CheckBoxEvents_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 209 | 210 | Const sSOURCE As String = "CheckBoxEvents_KeyDown" 211 | On Error GoTo ErrorHandler 212 | 213 | MyEventsKeyDown KeyCode, Shift 214 | 215 | ErrorExit: 216 | Exit Sub 217 | 218 | ErrorHandler: 219 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 220 | Stop 221 | Resume 222 | Else 223 | Resume ErrorExit 224 | End If 225 | 226 | End Sub 227 | 228 | Private Sub CheckBoxEvents_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 229 | 230 | Const sSOURCE As String = "CheckBoxEvents_MouseDown" 231 | On Error GoTo ErrorHandler 232 | 233 | MyEventsMouseDown Button, Shift, X, Y 234 | 235 | ErrorExit: 236 | Exit Sub 237 | 238 | ErrorHandler: 239 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 240 | Stop 241 | Resume 242 | Else 243 | Resume ErrorExit 244 | End If 245 | 246 | End Sub 247 | 248 | Private Sub TextBoxEvents_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 249 | 250 | Const sSOURCE As String = "TextBoxEvents_KeyDown" 251 | On Error GoTo ErrorHandler 252 | 253 | MyEventsKeyDown KeyCode, Shift 254 | 255 | ErrorExit: 256 | Exit Sub 257 | 258 | ErrorHandler: 259 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 260 | Stop 261 | Resume 262 | Else 263 | Resume ErrorExit 264 | End If 265 | 266 | End Sub 267 | 268 | Private Sub TextBoxEvents_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 269 | 270 | Const sSOURCE As String = "TextBoxEvents_MouseDown" 271 | On Error GoTo ErrorHandler 272 | 273 | MyEventsMouseDown Button, Shift, X, Y 274 | 275 | ErrorExit: 276 | Exit Sub 277 | 278 | ErrorHandler: 279 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 280 | Stop 281 | Resume 282 | Else 283 | Resume ErrorExit 284 | End If 285 | 286 | End Sub 287 | 288 | Private Sub MyEventsKeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 289 | 290 | Const sSOURCE As String = "MyEventsKeyDown" 291 | On Error GoTo ErrorHandler 292 | 293 | If p_oLabelControls.LabelControls.Count > 0 Then 294 | If p_ctlControl.Name = FormModerniserModule.LastTabbedControl Then 295 | If KeyCode = vbKeyReturn Then 296 | If FormModerniserModule.DefaultButton <> vbNullString Then 297 | CallByName gb_colCurrentUserForms.Item(1), SourceButtonName(FormModerniserModule.DefaultButton) & "_Click", VbMethod 298 | End If 299 | ElseIf KeyCode = vbKeyTab Or KeyCode = vbKeyDown Or KeyCode = vbKeyRight Then 300 | If FormModerniserModule.TabOverflow < p_oLabelControls.LabelControls.Count Then 301 | FormModerniserModule.TabOverflow = FormModerniserModule.TabOverflow + 1 302 | FormModerniserModule.DefaultButton = p_oLabelControls.LabelControls.Item(FormModerniserModule.TabOverflow).LabelName 303 | End If 304 | p_oLabelControls.UpdateControlButtonState FormModerniserModule.DefaultButton 305 | ElseIf KeyCode = vbKeyUp Or KeyCode = vbKeyLeft Then 306 | If FormModerniserModule.TabOverflow > 0 Then 307 | FormModerniserModule.TabOverflow = FormModerniserModule.TabOverflow - 1 308 | If FormModerniserModule.TabOverflow > 0 Then 309 | FormModerniserModule.DefaultButton = p_oLabelControls.LabelControls.Item(FormModerniserModule.TabOverflow).LabelName 310 | End If 311 | End If 312 | p_oLabelControls.UpdateControlButtonState FormModerniserModule.DefaultButton 313 | End If 314 | Else 315 | If KeyCode = vbKeyReturn Then 316 | If FormModerniserModule.DefaultButton <> vbNullString Then 317 | CallByName gb_colCurrentUserForms.Item(1), SourceButtonName(FormModerniserModule.DefaultButton) & "_Click", VbMethod 318 | End If 319 | End If 320 | If FormModerniserModule.TabOverflow > 0 Then 321 | p_ctlsControls(FormModerniserModule.LastTabbedControl).SetFocus 322 | End If 323 | End If 324 | End If 325 | 326 | Exit Sub 327 | 328 | ErrorHandler: 329 | ' Run simple clean-up code here 330 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 331 | Stop 332 | Resume 333 | End If 334 | 335 | End Sub 336 | 337 | Private Sub MyEventsMouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 338 | 339 | Const sSOURCE As String = "MyEventsMouseDown" 340 | On Error GoTo ErrorHandler 341 | 342 | FormModerniserModule.TabOverflow = 0 343 | 344 | Exit Sub 345 | 346 | ErrorHandler: 347 | ' Run simple clean-up code here 348 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 349 | Stop 350 | Resume 351 | End If 352 | 353 | End Sub 354 | 355 | 356 | Public Sub InitiateProperties(ByRef ctlControl As Control, _ 357 | ByRef oLabelControls As CLabelControls, _ 358 | ByRef ctlsControls As Controls) 359 | 360 | Const sSOURCE As String = "InitiateProperties" 361 | On Error GoTo ErrorHandler 362 | 363 | Set p_ctlControl = ctlControl 364 | Set p_oLabelControls = oLabelControls 365 | Set p_ctlsControls = ctlsControls 366 | 367 | Select Case TypeName(ctlControl) 368 | Case "TextBox" 369 | Set Me.TextBoxEvents = ctlControl 370 | FormModerniserModule.LastTabbedControl = ctlControl.Name 371 | Case "OptionButton" 372 | Set Me.OptionButtonEvents = ctlControl 373 | FormModerniserModule.LastTabbedControl = ctlControl.Name 374 | Case "ScrollBar" 375 | Set Me.ScrollBarEvents = ctlControl 376 | FormModerniserModule.LastTabbedControl = ctlControl.Name 377 | Case "SpinButton" 378 | Set Me.SpinButtonEvents = ctlControl 379 | FormModerniserModule.LastTabbedControl = ctlControl.Name 380 | Case "ListBox" 381 | Set Me.ListBoxEvents = ctlControl 382 | FormModerniserModule.LastTabbedControl = ctlControl.Name 383 | Case "TabStrip" 384 | Set Me.TabStripEvents = ctlControl 385 | FormModerniserModule.LastTabbedControl = ctlControl.Name 386 | Case "CheckBox" 387 | Set Me.CheckBoxEvents = ctlControl 388 | FormModerniserModule.LastTabbedControl = ctlControl.Name 389 | End Select 390 | 391 | Exit Sub 392 | 393 | ErrorHandler: 394 | ' Run simple clean-up code here 395 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 396 | Stop 397 | Resume 398 | End If 399 | 400 | End Sub 401 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/CLabelControl.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "CLabelControl" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | ' Copyright (c) Commtap CIC 2019 11 | ' Available under the MIT license: see the LICENSE file at the root of this 12 | ' project. 13 | ' Contact: tap@commtap.org 14 | 15 | Private Const msMODULE As String = "CLabelControl" 16 | 17 | Option Explicit 18 | 19 | Public WithEvents LabelControlEvents As MSForms.Label 20 | Attribute LabelControlEvents.VB_VarHelpID = -1 21 | 22 | Private p_ctlSurface As MSForms.Control 23 | Private p_ctlsUserFormControls As MSForms.Controls 24 | 25 | Private p_ctlText As MSForms.Control 26 | Private p_ctlBackground As MSForms.Control 27 | Private p_ctlBorder As MSForms.Control 28 | 29 | Private p_stName As String 30 | 31 | Private p_boolDefault As Boolean 32 | Private p_boolActive As Boolean 33 | 34 | Private p_stOnClickMethod As String 35 | 36 | Private Const p_stTEXTLAYER As String = "Caption" 37 | Private Const p_stBACKGROUNDLAYER As String = "Background" 38 | Private Const p_stBORDERLAYER As String = "Border" 39 | 40 | Public Property Get LabelName() As String 41 | LabelName = p_stName 42 | End Property 43 | 44 | Public Property Get ControlSurface() As MSForms.Control 45 | Set ControlSurface = p_ctlSurface 46 | End Property 47 | 48 | Private Sub LabelControlEvents_Click() 49 | CallByName gb_colCurrentUserForms.Item(1), p_stOnClickMethod, VbMethod 50 | End Sub 51 | 52 | ' The control consists of (from top to bottom): 53 | ' - Control Face Layer (where events are captured) - the original label but 54 | ' transparent and without any text. 55 | ' - Text layer - containing the orginal text - centred. 56 | ' - Fill layer - colour modifies according to the control state - slightly 57 | ' reduced in height and width compared to the top and bottom layer. 58 | ' - Border layer. 59 | ' 60 | Public Sub CreateLayers() 61 | 62 | Const sSOURCE As String = "CreateLayers" 63 | On Error GoTo ErrorHandler 64 | 65 | Dim stCaption As String 66 | Dim dblTop As Double 67 | Dim dblLeft As Double 68 | Dim dblWidth As Double 69 | Dim dblHeight As Double 70 | 71 | Dim dblTextHeight As Double 72 | 73 | With p_ctlSurface 74 | p_stName = .Name 75 | stCaption = .Caption 76 | dblTop = .Top 77 | dblLeft = .Left 78 | dblWidth = .Width 79 | dblHeight = .Height 80 | End With 81 | 82 | ' Border layer 83 | Set p_ctlBorder = p_ctlsUserFormControls.Add("Forms.Label.1", p_stName & "_" & p_stBORDERLAYER, True) 84 | With p_ctlBorder 85 | .Caption = vbNullString 86 | .BackStyle = fmBackStyleOpaque 87 | .BorderStyle = fmBorderStyleNone 88 | 89 | If p_boolDefault Then 90 | .BackColor = g_lngBTN_INACTIVE_DEFAULT_BORDER_COLOUR 91 | Else 92 | .BackColor = g_lngBTN_INACTIVE_BORDER_COLOUR 93 | End If 94 | 95 | .Top = dblTop 96 | .Left = dblLeft 97 | .Width = dblWidth 98 | .Height = dblHeight 99 | .ZOrder 0 100 | End With 101 | 102 | ' Background 103 | Set p_ctlBackground = p_ctlsUserFormControls.Add("Forms.Label.1", p_stName & "_" & p_stBACKGROUNDLAYER, True) 104 | With p_ctlBackground 105 | .Caption = vbNullString 106 | .BackStyle = fmBackStyleOpaque 107 | .BorderStyle = fmBorderStyleNone 108 | 109 | If p_boolDefault Then 110 | .BackColor = g_lngBTN_INACTIVE_DEFAULT_BACKGROUND_COLOUR 111 | Else 112 | .BackColor = g_lngBTN_INACTIVE_BACKGROUND_COLOUR 113 | End If 114 | .ZOrder 0 115 | 116 | End With 117 | 118 | Me.SetBorderWidth 119 | 120 | ' Caption - needs to stay just below control face. 121 | Set p_ctlText = p_ctlsUserFormControls.Add("Forms.Label.1", p_stName & "_" & p_stTEXTLAYER, True) 122 | With p_ctlText 123 | ' 1.35 appears to be the best factor to use (takes into account the padding 124 | ' added around text. 125 | .Font.Size = g_lngFONT_SIZE 126 | dblTextHeight = CDbl(.Font.Size) * 1.35 127 | .Caption = stCaption 128 | .BackStyle = fmBackStyleTransparent 129 | .BorderStyle = fmBorderStyleNone 130 | .ForeColor = g_lngFORE_COLOUR 131 | .Font.Name = "Calibri" 132 | .Top = (dblTop + (dblHeight / 2)) - (dblTextHeight / 2) 133 | .Left = dblLeft 134 | .Width = dblWidth 135 | .Height = dblTextHeight 136 | .TextAlign = fmTextAlignCenter 137 | .ZOrder 0 138 | End With 139 | 140 | ' The original item is the "control surface" and should stay 141 | ' on top. 142 | With p_ctlSurface 143 | .Caption = vbNullString 144 | .BackStyle = fmBackStyleTransparent 145 | .BorderStyle = fmBorderStyleNone 146 | .ZOrder 0 147 | End With 148 | 149 | Exit Sub 150 | 151 | ErrorHandler: 152 | ' Run simple clean-up code here 153 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 154 | Stop 155 | Resume 156 | End If 157 | 158 | End Sub 159 | 160 | 161 | Public Sub SetState(ByVal boolDefault As Boolean, _ 162 | ByVal lsState As lctlState, _ 163 | Optional ByVal boolLocationSet As Boolean = False, _ 164 | Optional ByVal X As Double, _ 165 | Optional ByVal Y As Double) 166 | 167 | Const sSOURCE As String = "SetState" 168 | On Error GoTo ErrorHandler 169 | 170 | p_boolDefault = boolDefault 171 | p_boolActive = False 172 | 173 | ' Check if mouse is over the button: 174 | If boolLocationSet Then 175 | If X < 0 Or X > p_ctlSurface.Width Or _ 176 | Y < 0 Or Y > p_ctlSurface.Height Then 177 | lsState = lctlInactive 178 | End If 179 | End If 180 | 181 | Select Case lsState 182 | Case lctlInactive 183 | If boolDefault Then 184 | p_ctlBackground.BackColor = g_lngBTN_INACTIVE_DEFAULT_BACKGROUND_COLOUR 185 | p_ctlBorder.BackColor = g_lngBTN_INACTIVE_DEFAULT_BORDER_COLOUR 186 | Else 187 | p_ctlBackground.BackColor = g_lngBTN_INACTIVE_BACKGROUND_COLOUR 188 | p_ctlBorder.BackColor = g_lngBTN_INACTIVE_BORDER_COLOUR 189 | End If 190 | 191 | Case lctlHover 192 | If boolDefault Then 193 | p_ctlBackground.BackColor = g_lngBTN_HOVER_DEFAULT_BACKGROUND_COLOUR 194 | p_ctlBorder.BackColor = g_lngBTN_HOVER_DEFAULT_BORDER_COLOUR 195 | Else 196 | p_ctlBackground.BackColor = g_lngBTN_HOVER_BACKGROUND_COLOUR 197 | p_ctlBorder.BackColor = g_lngBTN_HOVER_BORDER_COLOUR 198 | End If 199 | 200 | Case lctlActive 201 | ' Always default 202 | p_ctlBackground.BackColor = g_lngBTN_ACTIVE_DEFAULT_BACKGROUND_COLOUR 203 | p_ctlBorder.BackColor = g_lngBTN_ACTIVE_DEFAULT_BORDER_COLOUR 204 | p_boolActive = True 205 | 206 | End Select 207 | 208 | Me.SetBorderWidth 209 | 210 | Exit Sub 211 | 212 | ErrorHandler: 213 | ' Run simple clean-up code here 214 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 215 | Stop 216 | Resume 217 | End If 218 | 219 | End Sub 220 | 221 | Public Sub SetBorderWidth() 222 | 223 | Const sSOURCE As String = "SetBorderWidth" 224 | On Error GoTo ErrorHandler 225 | 226 | Dim dblBorderWidth As Double 227 | 228 | Dim dblTop As Double 229 | Dim dblLeft As Double 230 | Dim dblWidth As Double 231 | Dim dblHeight As Double 232 | 233 | With p_ctlSurface 234 | dblTop = .Top 235 | dblLeft = .Left 236 | dblWidth = .Width 237 | dblHeight = .Height 238 | End With 239 | 240 | Set p_ctlBackground = p_ctlsUserFormControls(p_stName & "_" & p_stBACKGROUNDLAYER) 241 | With p_ctlBackground 242 | If p_boolDefault Then 243 | If p_boolActive Then 244 | dblBorderWidth = g_dblBTN_DEFAULT_ACTIVE_BORDER_WIDTH 245 | Else 246 | dblBorderWidth = g_dblBTN_DEFAULT_BORDER_WIDTH 247 | End If 248 | Else 249 | dblBorderWidth = g_dblBTN_BORDER_WIDTH 250 | End If 251 | 252 | .Top = dblTop + dblBorderWidth 253 | .Left = dblLeft + dblBorderWidth 254 | .Width = dblWidth - (dblBorderWidth * 2) 255 | .Height = dblHeight - (dblBorderWidth * 2) 256 | End With 257 | 258 | Exit Sub 259 | 260 | ErrorHandler: 261 | ' Run simple clean-up code here 262 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 263 | Stop 264 | Resume 265 | End If 266 | 267 | End Sub 268 | 269 | Private Function CreateControlSurface(ByRef ctlCommandButton As Control) As Control 270 | 271 | Const sSOURCE As String = "CreateControlSurface" 272 | On Error GoTo ErrorHandler 273 | 274 | Dim stCaption As String 275 | Dim stName As String 276 | 277 | Dim dblTop As Double 278 | Dim dblLeft As Double 279 | Dim dblWidth As Double 280 | Dim dblHeight As Double 281 | 282 | Dim ctlSurface As Control 283 | 284 | AbsolutePosition ctlCommandButton, dblLeft, dblTop 285 | 286 | With ctlCommandButton 287 | stName = g_stLABEL_CONTROL_SUFFIX & .Name 288 | stCaption = .Caption 289 | 'dblTop = .Top 290 | 'dblLeft = .Left 291 | dblWidth = .Width 292 | dblHeight = .Height 293 | End With 294 | 295 | Set ctlSurface = p_ctlsUserFormControls.Add("Forms.Label.1", stName, True) 296 | With ctlSurface 297 | .Caption = stCaption 298 | .Top = dblTop 299 | .Left = dblLeft 300 | .Width = dblWidth 301 | .Height = dblHeight 302 | End With 303 | 304 | Set CreateControlSurface = ctlSurface 305 | 306 | Exit Function 307 | 308 | ErrorHandler: 309 | ' Run simple clean-up code here 310 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 311 | Stop 312 | Resume 313 | End If 314 | 315 | End Function 316 | 317 | 318 | 319 | Public Sub InitiateProperties(ByRef ctlsUserFormControls As MSForms.Controls, _ 320 | ByRef ctlCommandButton As MSForms.Control, _ 321 | Optional ByVal boolDefault As Boolean = False) 322 | 323 | Const sSOURCE As String = "InitiateProperties" 324 | On Error GoTo ErrorHandler 325 | 326 | Set p_ctlsUserFormControls = ctlsUserFormControls 327 | 328 | Set p_ctlSurface = CreateControlSurface(ctlCommandButton) 329 | Set Me.LabelControlEvents = p_ctlSurface 330 | 331 | p_stOnClickMethod = ctlCommandButton.Name & "_Click" 332 | 333 | p_ctlsUserFormControls(ctlCommandButton.Name).Visible = False 334 | 335 | p_boolDefault = boolDefault 336 | 337 | Me.CreateLayers 338 | 339 | Exit Sub 340 | 341 | ErrorHandler: 342 | ' Run simple clean-up code here 343 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 344 | Stop 345 | Resume 346 | End If 347 | 348 | End Sub 349 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/CLabelControlFrameResponder.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "CLabelControlFrameResponder" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | ' Copyright (c) Commtap CIC 2019 11 | ' Available under the MIT license: see the LICENSE file at the root of this 12 | ' project. 13 | ' Contact: tap@commtap.org 14 | 15 | Option Explicit 16 | 17 | Private Const msMODULE As String = "CLabelControlFrameResponder" 18 | 19 | ' Responds to Frame move events - to reset label button states as necessary. 20 | 21 | Public WithEvents FrameEvents As MSForms.Frame 22 | Attribute FrameEvents.VB_VarHelpID = -1 23 | 24 | Private p_oLabelControls As CLabelControls 25 | 26 | Private Sub FrameEvents_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 27 | 28 | Const sSOURCE As String = "FrameEvents_MouseMove" 29 | On Error GoTo ErrorHandler 30 | 31 | p_oLabelControls.UpdateControlButtonState 32 | 33 | ErrorExit: 34 | 35 | Exit Sub 36 | 37 | ErrorHandler: 38 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 39 | Stop 40 | Resume 41 | Else 42 | Resume ErrorExit 43 | End If 44 | 45 | End Sub 46 | 47 | 48 | Public Sub InitiateProperties(ByRef ctlFrameControl As Control, _ 49 | ByRef oLabelControls As CLabelControls) 50 | 51 | Const sSOURCE As String = "InitiateProperties" 52 | On Error GoTo ErrorHandler 53 | 54 | Set p_oLabelControls = oLabelControls 55 | Set Me.FrameEvents = ctlFrameControl 56 | 57 | Exit Sub 58 | 59 | ErrorHandler: 60 | ' Run simple clean-up code here 61 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 62 | Stop 63 | Resume 64 | End If 65 | 66 | End Sub 67 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/CLabelControlResponder.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "CLabelControlResponder" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | ' Copyright (c) Commtap CIC 2019 11 | ' Available under the MIT license: see the LICENSE file at the root of this 12 | ' project. 13 | ' Contact: tap@commtap.org 14 | 15 | Option Explicit 16 | 17 | Private Const msMODULE As String = "CLabelControlResponder" 18 | 19 | ' Responds to events on behalf of a CLabelControl. 20 | ' For adding additional control events onto the control surface. 21 | 22 | Public WithEvents LabelEvents As MSForms.Label 23 | Attribute LabelEvents.VB_VarHelpID = -1 24 | 25 | Private p_stButtonName As String 26 | Private p_oLabelControls As CLabelControls 27 | Private p_oLabelControl As CLabelControl 28 | 29 | Private Sub LabelEvents_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 30 | 31 | Const sSOURCE As String = "LabelEvents_MouseMove" 32 | On Error GoTo ErrorHandler 33 | 34 | If FormModerniserModule.ActiveButton = p_stButtonName Then 35 | p_oLabelControls.UpdateControlButtonState p_stButtonName, lctlActive, True, X, Y 36 | Else 37 | p_oLabelControls.UpdateControlButtonState p_stButtonName, lctlHover, True, X, Y 38 | End If 39 | 40 | ErrorExit: 41 | 42 | Exit Sub 43 | 44 | ErrorHandler: 45 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 46 | Stop 47 | Resume 48 | Else 49 | Resume ErrorExit 50 | End If 51 | 52 | End Sub 53 | 54 | Private Sub LabelEvents_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 55 | 56 | Const sSOURCE As String = "LabelEvents_MouseDown" 57 | On Error GoTo ErrorHandler 58 | 59 | FormModerniserModule.DefaultButton = p_stButtonName 60 | FormModerniserModule.ActiveButton = p_stButtonName 61 | p_oLabelControls.UpdateControlButtonState p_stButtonName, lctlActive 62 | 63 | ErrorExit: 64 | 65 | Exit Sub 66 | 67 | ErrorHandler: 68 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 69 | Stop 70 | Resume 71 | Else 72 | Resume ErrorExit 73 | End If 74 | 75 | End Sub 76 | 77 | Private Sub LabelEvents_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 78 | 79 | Const sSOURCE As String = "LabelEvents_MouseUp" 80 | On Error GoTo ErrorHandler 81 | 82 | p_oLabelControls.UpdateControlButtonState p_stButtonName, lctlHover, True, X, Y 83 | FormModerniserModule.ActiveButton = vbNullString 84 | 85 | ErrorExit: 86 | 87 | Exit Sub 88 | 89 | ErrorHandler: 90 | If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then 91 | Stop 92 | Resume 93 | Else 94 | Resume ErrorExit 95 | End If 96 | 97 | End Sub 98 | 99 | 100 | Public Sub InitiateProperties(ByVal oLabelControl As CLabelControl, _ 101 | ByRef oLabelControls As CLabelControls) 102 | 103 | Const sSOURCE As String = "InitiateProperties" 104 | On Error GoTo ErrorHandler 105 | 106 | Set p_oLabelControls = oLabelControls 107 | Set p_oLabelControl = oLabelControl 108 | 109 | p_stButtonName = oLabelControl.LabelName 110 | 111 | Set Me.LabelEvents = oLabelControl.ControlSurface 112 | 113 | Exit Sub 114 | 115 | ErrorHandler: 116 | ' Run simple clean-up code here 117 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 118 | Stop 119 | Resume 120 | End If 121 | 122 | End Sub 123 | 124 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/CLabelControls.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "CLabelControls" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | ' Copyright (c) Commtap CIC 2019 11 | ' Available under the MIT license: see the LICENSE file at the root of this 12 | ' project. 13 | ' Contact: tap@commtap.org 14 | 15 | Option Explicit 16 | 17 | Private Const msMODULE As String = "CLabelControls" 18 | 19 | Private p_colLabelControls As Collection 20 | Private p_arrLabelControlsOrder() As String 21 | Private p_ctlsControls As Controls 22 | 23 | Public Property Get LabelControls() As Collection 24 | Set LabelControls = p_colLabelControls 25 | End Property 26 | 27 | Public Sub CreateLayeredControls() 28 | 29 | Const sSOURCE As String = "CreateLayeredControls" 30 | On Error GoTo ErrorHandler 31 | 32 | Dim ctlControl As Control 33 | 34 | Dim colLabelControls As Collection 35 | Set colLabelControls = New Collection 36 | 37 | For Each ctlControl In p_ctlsControls 38 | If TypeName(ctlControl) = "CommandButton" Then 39 | colLabelControls.Add VFMFactory.CreateCLabelControl(p_ctlsControls, ctlControl), ctlControl.Name 40 | End If 41 | Next ctlControl 42 | 43 | Set p_colLabelControls = New Collection 44 | Dim stLabelControl As Variant 45 | 46 | For Each stLabelControl In p_arrLabelControlsOrder 47 | If KeyExistsInCollection(colLabelControls, stLabelControl) Then 48 | p_colLabelControls.Add colLabelControls(stLabelControl), stLabelControl 49 | colLabelControls.Remove stLabelControl 50 | End If 51 | Next stLabelControl 52 | 53 | ' Add on any remaining items that weren't in the label control order list: 54 | Dim oLabelControl As CLabelControl 55 | For Each oLabelControl In colLabelControls 56 | p_colLabelControls.Add oLabelControl, oLabelControl.LabelName 57 | Next oLabelControl 58 | 59 | Exit Sub 60 | 61 | ErrorHandler: 62 | ' Run simple clean-up code here 63 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 64 | Stop 65 | Resume 66 | End If 67 | 68 | End Sub 69 | 70 | Public Sub UpdateControlButtonState(Optional ByVal stControlName As String, _ 71 | Optional ByVal lsState As lctlState = lctlInactive, _ 72 | Optional ByVal boolLocationSet As Boolean = False, _ 73 | Optional ByVal X As Double, _ 74 | Optional ByVal Y As Double) 75 | 76 | Const sSOURCE As String = "UpdateControlButtonState" 77 | On Error GoTo ErrorHandler 78 | 79 | Dim stDefaultControlName As String 80 | stDefaultControlName = FormModerniserModule.DefaultButton 81 | 82 | Dim oLabelControl As CLabelControl 83 | 84 | For Each oLabelControl In p_colLabelControls 85 | If oLabelControl.LabelName = stControlName Then 86 | If oLabelControl.LabelName = stDefaultControlName Then 87 | oLabelControl.SetState True, lsState, boolLocationSet, X, Y 88 | Else 89 | oLabelControl.SetState False, lsState, boolLocationSet, X, Y 90 | End If 91 | Else 92 | If oLabelControl.LabelName = stDefaultControlName Then 93 | oLabelControl.SetState True, lctlInactive, boolLocationSet, X, Y 94 | Else 95 | oLabelControl.SetState False, lctlInactive, boolLocationSet, X, Y 96 | End If 97 | End If 98 | Next oLabelControl 99 | 100 | Exit Sub 101 | 102 | ErrorHandler: 103 | ' Run simple clean-up code here 104 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 105 | Stop 106 | Resume 107 | End If 108 | 109 | End Sub 110 | 111 | 112 | Public Sub InitiateProperties(ByRef ctlsControls As MSForms.Controls, _ 113 | ByRef arrLabelControlsOrder() As String) 114 | 115 | Const sSOURCE As String = "InitiateProperties" 116 | On Error GoTo ErrorHandler 117 | 118 | p_arrLabelControlsOrder = arrLabelControlsOrder 119 | 120 | Set p_ctlsControls = ctlsControls 121 | CreateLayeredControls 122 | 123 | Exit Sub 124 | 125 | ErrorHandler: 126 | ' Run simple clean-up code here 127 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 128 | Stop 129 | Resume 130 | End If 131 | 132 | End Sub 133 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/CLabelControlsManager.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "CLabelControlsManager" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | ' Copyright (c) Commtap CIC 2019 11 | ' Available under the MIT license: see the LICENSE file at the root of this 12 | ' project. 13 | ' Contact: tap@commtap.org 14 | 15 | Option Explicit 16 | 17 | Private Const msMODULE As String = "CLabelControlsManager" 18 | 19 | Private p_oLabelControls As CLabelControls 20 | Private p_ctlsControls As Controls 21 | Private p_colControlResponders As Collection 22 | Private p_colFrameControls As Collection 23 | 24 | Private p_colKeyDownControls As Collection 25 | 26 | Public Property Get LabelControls() As CLabelControls 27 | Set LabelControls = p_oLabelControls 28 | End Property 29 | 30 | Public Sub CreateControlResponders() 31 | 32 | Const sSOURCE As String = "CreateControlResponders" 33 | On Error GoTo ErrorHandler 34 | 35 | Set p_colControlResponders = New Collection 36 | 37 | Dim colLabelControls As Collection 38 | Set colLabelControls = p_oLabelControls.LabelControls 39 | 40 | Dim oLabelControl As CLabelControl 41 | For Each oLabelControl In colLabelControls 42 | 43 | p_colControlResponders.Add VFMFactory.CreateCLabelControlResponder(oLabelControl, _ 44 | p_oLabelControls) 45 | 46 | Next oLabelControl 47 | 48 | Exit Sub 49 | 50 | ErrorHandler: 51 | ' Run simple clean-up code here 52 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 53 | Stop 54 | Resume 55 | End If 56 | 57 | End Sub 58 | 59 | Public Sub CreateFrameControlResponders(Optional ByVal stNamePrefix As String) 60 | 61 | Const sSOURCE As String = "CreateFrameControls" 62 | On Error GoTo ErrorHandler 63 | 64 | Dim ctlControl As Control 65 | Set p_colFrameControls = New Collection 66 | 67 | For Each ctlControl In p_ctlsControls 68 | If TypeName(ctlControl) = "Frame" Then 69 | If Mid(ctlControl.Name, 1, Len(stNamePrefix)) = stNamePrefix Then 70 | p_colFrameControls.Add VFMFactory.CreateCLabelControlFrameResponder(ctlControl, p_oLabelControls), _ 71 | ctlControl.Name 72 | End If 73 | End If 74 | Next ctlControl 75 | 76 | Exit Sub 77 | 78 | ErrorHandler: 79 | ' Run simple clean-up code here 80 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 81 | Stop 82 | Resume 83 | End If 84 | 85 | End Sub 86 | 87 | Public Sub CreateKeyDownResponders() 88 | 89 | Const sSOURCE As String = "CreateKeyDownResponders" 90 | On Error GoTo ErrorHandler 91 | 92 | Dim ctlControl As Control 93 | 94 | FormModerniserModule.TabOverflow = 0 95 | FormModerniserModule.LastTabbedControl = vbNullString 96 | 97 | Set p_colKeyDownControls = New Collection 98 | 99 | For Each ctlControl In p_ctlsControls 100 | If TypeName(ctlControl) = "CheckBox" Or _ 101 | TypeName(ctlControl) = "OptionButton" Or _ 102 | TypeName(ctlControl) = "ScrollBar" Or _ 103 | TypeName(ctlControl) = "SpinButton" Or _ 104 | TypeName(ctlControl) = "ListBox" Or _ 105 | TypeName(ctlControl) = "TabStrip" Or _ 106 | TypeName(ctlControl) = "TextBox" Then 107 | p_colKeyDownControls.Add VFMFactory.CreateCKeyDownResponder(ctlControl, p_oLabelControls, p_ctlsControls), _ 108 | ctlControl.Name 109 | End If 110 | Next ctlControl 111 | 112 | Exit Sub 113 | 114 | ErrorHandler: 115 | ' Run simple clean-up code here 116 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 117 | Stop 118 | Resume 119 | End If 120 | 121 | End Sub 122 | 123 | ' Checks that the default buttons are correct for this set of controls and 124 | ' resets them if not. 125 | Public Sub CheckDefaults() 126 | 127 | If Not ControlExists(p_ctlsControls, FormModerniserModule.ActiveButton) Then 128 | FormModerniserModule.ActiveButton = vbNullString 129 | End If 130 | 131 | If Not ControlExists(p_ctlsControls, FormModerniserModule.DefaultButton) Then 132 | FormModerniserModule.DefaultButton = vbNullString 133 | End If 134 | 135 | End Sub 136 | 137 | Public Sub InitiateProperties(ByRef ctlsControls As MSForms.Controls, _ 138 | ByRef arrLabelControlsOrder() As String) 139 | 140 | Const sSOURCE As String = "InitiateProperties" 141 | On Error GoTo ErrorHandler 142 | 143 | Set p_ctlsControls = ctlsControls 144 | 145 | Set p_oLabelControls = VFMFactory.CreateCLabelControls(ctlsControls, arrLabelControlsOrder) 146 | CheckDefaults 147 | 148 | p_oLabelControls.UpdateControlButtonState 149 | 150 | Me.CreateControlResponders 151 | Me.CreateFrameControlResponders 152 | Me.CreateKeyDownResponders 153 | 154 | Exit Sub 155 | 156 | ErrorHandler: 157 | ' Run simple clean-up code here 158 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 159 | Stop 160 | Resume 161 | End If 162 | 163 | End Sub 164 | 165 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/FormModerniserDevPPT.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "FormModerniserDevPPT" 2 | Option Explicit 3 | 4 | ' This module should be loaded in PowerPoint only. 5 | 6 | ' Get the VBProject 7 | Public Function VFM_ImportModule(ByVal stModulePath As String) As Object 8 | Set VFM_ImportModule = Application.ActivePresentation.VBProject.VBComponents.Import(stModulePath) 9 | End Function 10 | 11 | Public Function VFM_RemoveModule(ByVal stModuleName As String) 12 | With Application.ActivePresentation.VBProject 13 | On Error Resume Next 14 | .VBComponents.Remove .VBComponents(stModuleName) 15 | On Error GoTo 0 16 | End With 17 | End Function 18 | 19 | Public Function VFM_ExportModules(ByVal stModuleNames As String, ByVal stFolderPath As String) 20 | 21 | Const vbext_ct_StdModule = 1 22 | Const vbext_ct_ClassModule = 2 23 | Const vbext_ct_MSForm = 3 24 | 25 | Dim cmpComponent 26 | Dim stFileName As String 27 | 28 | stModuleNames = " " & stModuleNames & " " 29 | 30 | With Application.ActivePresentation.VBProject 31 | For Each cmpComponent In .VBComponents 32 | If InStr(stModuleNames, " " & cmpComponent.Name & " ") Then 33 | stFileName = vbNullString 34 | Select Case .VBComponents(cmpComponent.Name).Type 35 | Case vbext_ct_ClassModule 36 | stFileName = cmpComponent.Name & ".cls" 37 | Case vbext_ct_MSForm 38 | stFileName = cmpComponent.Name & ".frm" 39 | Case vbext_ct_StdModule 40 | stFileName = cmpComponent.Name & ".bas" 41 | End Select 42 | If stFileName <> vbNullString Then 43 | cmpComponent.Export VFMFileAddTrailingSlash(stFolderPath) & stFileName 44 | End If 45 | End If 46 | Next cmpComponent 47 | 48 | End With 49 | End Function 50 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/FormModerniserDevUtility.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "FormModerniserDevUtility" 2 | Option Explicit 3 | 4 | ' TODO: 5 | ' Some of this could be created as a separate add-in 6 | ' Specifics for a project would be created in project files 7 | ' VFMUtility and ppt/excel/word specific bits could be imported if they 8 | ' already exist. 9 | 10 | Private Const m_stFormModerniserModule As String = "FormModerniserModule.bas" 11 | Private Const m_stDevUtilityVersion As String = "1.22" 12 | 13 | Private m_stCurrentVersion As String 14 | Private m_boolCurrentVersionLoaded As Boolean 15 | 16 | ' Use to import modules into your project: 17 | Private Sub VFMImport() 18 | VFMImportModules 19 | End Sub 20 | 21 | ' Run this if asked to: 22 | Private Sub VFMStoreVersionNumber() 23 | VFMStoreCurrentVersionNumber 24 | End Sub 25 | 26 | Private Sub VFMExport() 27 | VFMExportToFiles 28 | End Sub 29 | 30 | ' ============================================================================= 31 | 32 | Public Function VFMFileNames(Optional ByVal boolImport As Boolean = True) As String 33 | ' Names must be separated by spaces. 34 | ' The file extension is included for importing - but not exporting. 35 | If boolImport Then 36 | VFMFileNames = "CKeyDownResponder.cls " & _ 37 | "CLabelControl.cls " & _ 38 | "CLabelControlFrameResponder.cls " & _ 39 | "CLabelControlResponder.cls " & _ 40 | "CLabelControls.cls " & _ 41 | "CLabelControlsManager.cls " & _ 42 | "FormModerniserModule.bas " & _ 43 | "VFMFactory.bas" 44 | Else 45 | VFMFileNames = "CKeyDownResponder " & _ 46 | "CLabelControl " & _ 47 | "CLabelControlFrameResponder " & _ 48 | "CLabelControlResponder " & _ 49 | "CLabelControls " & _ 50 | "CLabelControlsManager " & _ 51 | "FormModerniserDevPPT " & _ 52 | "FormModerniserDevWord " & _ 53 | "FormModerniserDevExcel " & _ 54 | "FormModerniserDevUtility " & _ 55 | "FormModerniserModule " & _ 56 | "VFMFactory" 57 | End If 58 | End Function 59 | 60 | Private Function VFMStoreCurrentVersionNumber() As String 61 | m_stCurrentVersion = FormModerniserModule.g_stVERSION 62 | m_boolCurrentVersionLoaded = True 63 | MsgBox "Current version number (" & m_stCurrentVersion & ") stored.", vbInformation 64 | End Function 65 | 66 | Private Function VFMVersionFromFile(ByVal stFolderPath As String, Optional ByVal stVersionType As String = "macro") As String 67 | 68 | Dim stFileName As String 69 | Dim stVersionIdentifier As String 70 | 71 | Select Case stVersionType 72 | Case "macro" 73 | stFileName = m_stFormModerniserModule 74 | stVersionIdentifier = "Public Const g_stVERSION As String = " 75 | Case "devutility" 76 | stFileName = "FormModerniserDevUtility.bas" 77 | stVersionIdentifier = "Private Const m_stDevUtilityVersion As String = " 78 | Case Else 79 | Exit Function 80 | End Select 81 | 82 | Dim fso, f 83 | Set fso = CreateObject("Scripting.FileSystemObject") 84 | Const ForReading As Long = 1 85 | 86 | Dim stFilePath As String 87 | stFilePath = VFMFileAddTrailingSlash(stFolderPath) & stFileName 88 | 89 | If Not fso.FileExists(stFilePath) Then 90 | Exit Function 91 | End If 92 | 93 | Dim boolVersionFound As Boolean 94 | Dim stLine As String 95 | Dim stVersion As String 96 | 97 | Set f = fso.OpenTextFile(FileName:=stFilePath, iomode:=ForReading, Format:=0) 98 | Do While f.AtEndOfStream <> True And boolVersionFound <> True 99 | stLine = Trim$(f.Readline) 100 | If Mid(stLine, 1, Len(stVersionIdentifier)) = stVersionIdentifier Then 101 | stVersion = Mid(stLine, Len(stVersionIdentifier) + 1) 102 | ' Removes leading and trailing quotes: 103 | stVersion = Mid(stVersion, 2, Len(stVersion) - 2) 104 | boolVersionFound = True 105 | End If 106 | Loop 107 | f.Close 108 | 109 | VFMVersionFromFile = stVersion 110 | 111 | End Function 112 | 113 | Private Sub VFMImportModules() 114 | 115 | ' As the current version exists in a module we want to replace, we 116 | ' cannot get anything from that module when attempting to replace it - 117 | ' so a separate procedure must be run first to store the version before 118 | ' running this one. 119 | If Not m_boolCurrentVersionLoaded Then 120 | MsgBox "Please run ""VFMStoreVersionNumber"" first.", vbExclamation 121 | Exit Sub 122 | End If 123 | 124 | Dim stFileNames() As String 125 | stFileNames = Split(VFMFileNames) 126 | 127 | Dim fso 128 | Set fso = CreateObject("Scripting.FileSystemObject") 129 | 130 | Dim stFolderPath As String 131 | stFolderPath = VFMGetFolder(vbNullString) 132 | 133 | ' (1) Browse to source folder 134 | If stFolderPath = vbNullString Then 135 | Exit Sub 136 | End If 137 | 138 | Dim boolAllFilesExist As Boolean 139 | boolAllFilesExist = True 140 | 141 | Dim stFileName As Variant 142 | For Each stFileName In stFileNames 143 | If Not fso.FileExists(stFolderPath & "\" & stFileName) Then 144 | boolAllFilesExist = False 145 | Exit For 146 | End If 147 | Next stFileName 148 | 149 | If Not boolAllFilesExist Then 150 | MsgBox "Not all the expected files exist. Aborting. Nothing has been imported.", vbExclamation + vbOKOnly, "Import" 151 | Exit Sub 152 | End If 153 | 154 | Dim stModuleNameList As String 155 | stModuleNameList = Join(stFileNames, vbCrLf) 156 | 157 | Dim stCurrentVersion As String 158 | stCurrentVersion = m_stCurrentVersion 159 | 160 | Dim stVersionFromFile As String 161 | stVersionFromFile = VFMVersionFromFile(stFolderPath) 162 | 163 | Dim stDevUtilityVersion As String 164 | stDevUtilityVersion = m_stDevUtilityVersion 165 | Dim stDevUtilityVersionFromFile As String 166 | stDevUtilityVersionFromFile = VFMVersionFromFile(stFolderPath, "devutility") 167 | 168 | Dim stDevUtilityMsg As String 169 | If stDevUtilityVersionFromFile <> vbNullString Then 170 | If stDevUtilityVersion <> stDevUtilityVersionFromFile Then 171 | 172 | Dim stDiffVersion As String 173 | 174 | If CDbl(stDevUtilityVersion) > CDbl(stDevUtilityVersionFromFile) Then 175 | stDiffVersion = "*newer*" 176 | Else 177 | stDiffVersion = "older" 178 | End If 179 | 180 | stDevUtilityMsg = "The version of the DevUtility module you are " & _ 181 | "using (" & stDevUtilityVersion & ") is " & stDiffVersion & " than the version " & _ 182 | "of the DevUtility module in the folder you are " & _ 183 | "importing from (" & stDevUtilityVersionFromFile & "). " & _ 184 | "You should import that manually first before " & _ 185 | "proceeding." 186 | 187 | MsgBox stDevUtilityMsg, vbOKOnly + vbExclamation, "Form Moderniser Import" 188 | m_boolCurrentVersionLoaded = False 189 | Exit Sub 190 | End If 191 | End If 192 | 193 | Dim stOtherInfoMsg As String 194 | stOtherInfoMsg = "Note: this does NOT load the VFMUtility module - do this " & _ 195 | "manually as and when necessary. You will " & _ 196 | "also need to have the appropriate FormModerniserDevPPT/Excel/Word " & _ 197 | "module." 198 | 199 | Dim stTargetDocument As String 200 | stTargetDocument = VFMCurrentDocument 201 | 202 | Dim stBackupPath As String 203 | stBackupPath = VFMBackupFilePath 204 | 205 | ' (3) 206 | Dim stMsg As String 207 | stMsg = stOtherInfoMsg & vbCrLf & vbCrLf 208 | stMsg = stMsg & "Current version: " & stCurrentVersion & vbCrLf 209 | stMsg = stMsg & "Version to be imported: " & stVersionFromFile & vbCrLf & vbCrLf 210 | stMsg = stMsg & "Source Folder: " & stFolderPath & vbCrLf 211 | stMsg = stMsg & "Target Document: " & stTargetDocument & vbCrLf 212 | stMsg = stMsg & "Backup path for current document: " & stBackupPath & vbCrLf & vbCrLf 213 | stMsg = stMsg & "The following modules will be imported - replacing existing modules with the same name: " & vbCrLf 214 | stMsg = stMsg & stModuleNameList & vbCrLf & vbCrLf 215 | stMsg = stMsg & "Make sure you have saved this document before proceding. " & _ 216 | "This utility does create a backup - but only of the last " & _ 217 | "saved version." & vbCrLf & vbCrLf 218 | stMsg = stMsg & "Do you want to continue?" 219 | 220 | If MsgBox(stMsg, vbYesNoCancel + vbInformation, "Form Moderniser Module Import") <> vbYes Then 221 | Exit Sub 222 | End If 223 | 224 | Dim stCurrentDocumentPath As String 225 | stCurrentDocumentPath = VFMFileAddTrailingSlash(VFMCurrentFolder) & VFMCurrentDocument 226 | 227 | VFMBackup stCurrentDocumentPath, stBackupPath 228 | 229 | Dim stModulePath As String 230 | 231 | For Each stFileName In stFileNames 232 | stModulePath = stFolderPath & "\" & stFileName 233 | VFM_RemoveModule VFMFileName(stModulePath, False) 234 | VFM_ImportModule stModulePath 235 | Next stFileName 236 | 237 | ' Message about renaming: 238 | MsgBox "One or more modules may have been renamed and now have a ""1""" & _ 239 | "added. You should manually rename these modules - removing the ""1"".", _ 240 | vbExclamation + vbOKOnly 241 | 242 | m_boolCurrentVersionLoaded = False 243 | 244 | End Sub 245 | 246 | Private Sub VFMExportToFiles() 247 | 248 | Dim stFolderPath As String 249 | stFolderPath = VFMGetFolder(vbNullString) 250 | 251 | Dim stModuleNames As String 252 | stModuleNames = Replace(VFMFileNames(False), " ", vbCrLf) 253 | 254 | Dim stMsg As String 255 | stMsg = "Are you sure you would like to export the following modules (where they exist):" & _ 256 | vbCrLf & stModuleNames & vbCrLf & "to " & stFolderPath & "?" & vbCrLf & _ 257 | "Any existing files will be overwritten." 258 | 259 | If MsgBox(stMsg, vbYesNoCancel + vbInformation, "Module Export") <> vbYes Then 260 | Exit Sub 261 | End If 262 | 263 | If stFolderPath <> vbNullString Then 264 | VFM_ExportModules VFMFileNames(False), stFolderPath 265 | End If 266 | 267 | End Sub 268 | 269 | ' File Functions 270 | ' ============== 271 | 272 | ' Returns unique file path for given file path - by altering the file name. 273 | Private Function VFMUniqueFilePath(stFilePath As String) As String 274 | 275 | Dim stUniqueFilePath As String 276 | Dim i As Long 277 | 278 | Dim fso 279 | Set fso = CreateObject("Scripting.FileSystemObject") 280 | 281 | stUniqueFilePath = stFilePath 282 | 283 | If fso.FileExists(stFilePath) Then 284 | 285 | i = 0 286 | Dim stFileFolderPath As String 287 | Dim stFileName As String 288 | Dim stFileExt As String 289 | Dim boolFileFound As Boolean 290 | 291 | stFileFolderPath = VFMFileFolderPath(stFilePath) 292 | stFileName = VFMFileName(stFilePath, False) 293 | stFileExt = VFMFileExt(stFilePath) 294 | 295 | If stFileExt <> vbNullString Then 296 | stFileExt = "." & stFileExt 297 | End If 298 | 299 | ' Looking for " (dd)" at end of file name 300 | Do While boolFileFound = False 301 | i = i + 1 302 | stUniqueFilePath = stFileFolderPath & stFileName & " (" & i & ")" & stFileExt 303 | If fso.FileExists(stUniqueFilePath) <> True Then 304 | boolFileFound = True 305 | End If 306 | Loop 307 | End If 308 | 309 | VFMUniqueFilePath = stUniqueFilePath 310 | 311 | End Function 312 | 313 | Private Function VFMTrailingSlash(varIn As Variant) As String 314 | If Len(varIn) > 0& Then 315 | If Right$(varIn, 1&) = "\" Then 316 | VFMTrailingSlash = varIn 317 | Else 318 | VFMTrailingSlash = varIn & "\" 319 | End If 320 | End If 321 | End Function 322 | 323 | Private Function VFMFileExt(stPath) As String 324 | If InStr(stPath, ".") > 0 Then 325 | VFMFileExt = Right$(stPath, Len(stPath) - InStrRev(stPath, ".")) 326 | Else 327 | VFMFileExt = vbNullString 328 | End If 329 | End Function 330 | 331 | Private Function VFMFileStripTrailingSlash(stPath) As String 332 | VFMFileStripTrailingSlash = stPath 333 | If Len(stPath) > 0 Then 334 | If Right$(stPath, 1) = "\" Then 335 | VFMFileStripTrailingSlash = Mid$(stPath, 1, Len(stPath) - 1) 336 | End If 337 | End If 338 | End Function 339 | 340 | Public Function VFMFileAddTrailingSlash(stPath) As String 341 | VFMFileAddTrailingSlash = stPath 342 | If Len(stPath) > 0 Then 343 | If Not Right$(stPath, 1) = "\" Then 344 | VFMFileAddTrailingSlash = stPath & "\" 345 | End If 346 | Else 347 | VFMFileAddTrailingSlash = "\" 348 | End If 349 | End Function 350 | 351 | ' Returns the file name without the extension: 352 | ' For folders, the trailing slash - if any - is stripped off first 353 | Private Function VFMFileName(ByVal stPath As String, Optional ByVal lower_case As Boolean = True, _ 354 | Optional ByVal boolFolder = False) As String 355 | 356 | Dim stFileName As String 357 | 358 | stFileName = VFMFileStripTrailingSlash(stPath) 359 | stFileName = Mid$(stFileName, InStrRev(stFileName, "\") + 1) 360 | 361 | If InStrRev(stFileName, ".") <> 0 And InStr(stFileName, ".") <> 1 And boolFolder <> True Then 362 | stFileName = Mid$(stFileName, InStrRev(stFileName, "\") + 1, InStrRev(stFileName, ".") - InStrRev(stFileName, "\") - 1) 363 | End If 364 | 365 | If lower_case = True Then 366 | stFileName = LCase$(stFileName) 367 | End If 368 | 369 | VFMFileName = stFileName 370 | 371 | End Function 372 | 373 | Private Function VFMFileNameWithExt(stPath) As String 374 | VFMFileNameWithExt = Mid$(stPath, InStrRev(stPath, "\") + 1) 375 | End Function 376 | 377 | ' Gets the folder path from a full path to a file 378 | Private Function VFMFileFolderPath(stPath) As String 379 | Dim stFileNameWithExt 380 | stFileNameWithExt = VFMFileNameWithExt(stPath) 381 | VFMFileFolderPath = Mid$(stPath, 1, Len(stPath) - Len(stFileNameWithExt)) 382 | End Function 383 | 384 | Private Function VFMGetFolder(ByVal strPath As String) As String 385 | 386 | Dim fldr As FileDialog 387 | Dim sItem As String 388 | sItem = vbNullString 389 | Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 390 | With fldr 391 | .Title = "Select a Folder" 392 | .AllowMultiSelect = False 393 | .InitialFileName = strPath 394 | If .Show <> -1 Then GoTo NextCode 395 | sItem = .SelectedItems(1) 396 | End With 397 | NextCode: 398 | VFMGetFolder = sItem 399 | Set fldr = Nothing 400 | 401 | End Function 402 | 403 | ' Information about the current document 404 | ' ====================================== 405 | 406 | Private Function VFMCurrentDocument() As String 407 | Dim stCurrentDocument As String 408 | 409 | Select Case Application.Name 410 | Case "Microsoft PowerPoint" 411 | stCurrentDocument = CallByName(CallByName(Application, "ActivePresentation", VbGet), "Name", VbGet) 412 | Case "Microsoft Excel" 413 | stCurrentDocument = CallByName(CallByName(Application, "ActiveWorkbook", VbGet), "Name", VbGet) 414 | Case "Microsoft Word" 415 | stCurrentDocument = CallByName(CallByName(Application, "ActiveDocument", VbGet), "Name", VbGet) 416 | End Select 417 | 418 | VFMCurrentDocument = stCurrentDocument 419 | End Function 420 | 421 | Private Function VFMCurrentFolder() As String 422 | Dim stCurrentFolder As String 423 | 424 | Select Case Application.Name 425 | Case "Microsoft PowerPoint" 426 | stCurrentFolder = CallByName(CallByName(Application, "ActivePresentation", VbGet), "Path", VbGet) 427 | Case "Microsoft Excel" 428 | stCurrentFolder = CallByName(CallByName(Application, "ActiveWorkbook", VbGet), "Path", VbGet) 429 | Case "Microsoft Word" 430 | stCurrentFolder = CallByName(CallByName(Application, "ActiveDocument", VbGet), "Path", VbGet) 431 | End Select 432 | 433 | VFMCurrentFolder = stCurrentFolder 434 | End Function 435 | 436 | Private Function VFMBackupFilePath() As String 437 | VFMBackupFilePath = VFMUniqueFilePath(VFMFileAddTrailingSlash(VFMCurrentFolder) & VFMCurrentDocument & ".bak") 438 | End Function 439 | 440 | Private Function VFMBackup(ByVal stSource As String, ByVal stTarget As String) 441 | 442 | Dim fso 443 | Set fso = CreateObject("Scripting.FileSystemObject") 444 | 445 | fso.CopyFile stSource, stTarget, False 446 | 447 | End Function 448 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/FormModerniserDevWord.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "FormModerniserDevWord" 2 | Option Explicit 3 | 4 | ' This module should be loaded in PowerPoint only. 5 | 6 | ' Get the VBProject 7 | Public Function VFM_ImportModule(ByVal stModulePath As String) As Object 8 | Set VFM_ImportModule = Application.ActiveDocument.VBProject.VBComponents.Import(stModulePath) 9 | End Function 10 | 11 | Public Function VFM_RemoveModule(ByVal stModuleName As String) 12 | With Application.ActiveDocument.VBProject 13 | On Error Resume Next 14 | .VBComponents.Remove .VBComponents(stModuleName) 15 | On Error GoTo 0 16 | End With 17 | End Function 18 | 19 | Public Function VFM_ExportModules(ByVal stModuleNames As String, ByVal stFolderPath As String) 20 | 21 | Const vbext_ct_StdModule = 1 22 | Const vbext_ct_ClassModule = 2 23 | Const vbext_ct_MSForm = 3 24 | 25 | Dim cmpComponent 26 | Dim stFileName As String 27 | 28 | stModuleNames = " " & stModuleNames & " " 29 | 30 | With Application.ActiveDocument.VBProject 31 | For Each cmpComponent In .VBComponents 32 | If InStr(stModuleNames, " " & cmpComponent.Name & " ") Then 33 | stFileName = vbNullString 34 | Select Case .VBComponents(cmpComponent.Name).Type 35 | Case vbext_ct_ClassModule 36 | stFileName = cmpComponent.Name & ".cls" 37 | Case vbext_ct_MSForm 38 | stFileName = cmpComponent.Name & ".frm" 39 | Case vbext_ct_StdModule 40 | stFileName = cmpComponent.Name & ".bas" 41 | End Select 42 | If stFileName <> vbNullString Then 43 | cmpComponent.Export VFMFileAddTrailingSlash(stFolderPath) & stFileName 44 | End If 45 | End If 46 | Next cmpComponent 47 | 48 | End With 49 | End Function 50 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/FormModerniserModule.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "FormModerniserModule" 2 | ' Copyright (c) Commtap CIC 2019 3 | ' Available under the MIT license: see the LICENSE file at the root of this 4 | ' project. 5 | ' Contact: tap@commtap.org 6 | 7 | ' Note buttons in office generally have a standard height and width. 8 | ' TODO: have a switch to switch off form modernisation. 9 | 10 | Option Explicit 11 | 12 | Private Const msMODULE As String = "FormModerniserModule" 13 | 14 | Public Const g_stVERSION As String = "2.13-beta" 15 | 16 | ' Used for styling the label buttons. 17 | Private m_stDefaultButton As String 18 | Private m_stActiveButton As String 19 | 20 | ' Suffix for label control surface created from a command button: 21 | Public Const g_stLABEL_CONTROL_SUFFIX As String = "VFMLabelControl_" 22 | ' Any other label which is not being used as a control: 23 | Public Const g_stLABEL_SUFFIX As String = "VFMLabel_" 24 | 25 | ' Used to capture returns and tabbing from controls to the label buttons. 26 | ' Tab as in keyboard tab. 27 | Private m_lngTabOverflow As Long 28 | Private m_stLastTabbedControl As String 29 | 30 | ' Store reference userform 31 | ' Need one for each type of form in the project - early binding 32 | ' otherwise callbyname won't work. 33 | Public gb_colCurrentUserForms As Collection 34 | 35 | ' General styling 36 | Public Const g_lngFORE_COLOUR As Long = &H464646 37 | Public Const g_stFONT_NAME As String = "Calibri" 38 | Public Const g_lngFONT_SIZE = 10 39 | Public Const g_lngFORM_BACK_COLOUR = &HE6E6E6 40 | Public Const g_lngBACK_COLOUR = &HFFFFFF 41 | Public Const g_lngBORDER_COLOUR As Long = &HA9A9A9 42 | Public Const g_lngSPECIAL_EFFECT As Long = fmSpecialEffectFlat 43 | Public Const g_lngTEXTBOX_BORDERSTYLE As Long = fmBorderStyleSingle 44 | 45 | Public Const g_lngOUTER_FRAME_BORDER_COLOUR As Long = &HD9D9D9 46 | Public Const g_lngINNER_FRAME_BORDER_COLOUR As Long = &HDCDCDC 47 | 48 | 49 | ' Labels used as buttons specific styling 50 | Public Const g_dblBTN_BORDER_WIDTH As Double = 1 51 | Public Const g_dblBTN_DEFAULT_BORDER_WIDTH As Double = 2 52 | Public Const g_dblBTN_DEFAULT_ACTIVE_BORDER_WIDTH As Double = 3 53 | 54 | ' Link colours 55 | Public Const g_lngLINK_COLOUR As Long = &H996633 56 | 57 | ' These colours apply to the options pane in PowerPoint: these colours vary 58 | ' between Office products. 59 | 'Public Const g_lngBTN_ACTIVE_DEFAULT_BORDER_COLOUR As Long = &H565D71 60 | 'Public Const g_lngBTN_HOVER_DEFAULT_BORDER_COLOUR As Long = &H7E95C4 61 | 'Public Const g_lngBTN_HOVER_BORDER_COLOUR As Long = &H7E95C4 62 | 'Public Const g_lngBTN_INACTIVE_DEFAULT_BORDER_COLOUR As Long = &H3959DC 63 | 'Public Const g_lngBTN_INACTIVE_BORDER_COLOUR As Long = &HABABAB 64 | ' 65 | 'Public Const g_lngBTN_ACTIVE_DEFAULT_BACKGROUND_COLOUR As Long = &H9DBAF5 66 | 'Public Const g_lngBTN_HOVER_DEFAULT_BACKGROUND_COLOUR As Long = &HDCE4FC 67 | 'Public Const g_lngBTN_HOVER_BACKGROUND_COLOUR As Long = &HDCE4FC 68 | 'Public Const g_lngBTN_INACTIVE_DEFAULT_BACKGROUND_COLOUR As Long = &HFDFDFD 69 | 'Public Const g_lngBTN_INACTIVE_BACKGROUND_COLOUR As Long = &HFDFDFD 70 | 71 | ' Shades of blue 72 | Public Const g_lngBTN_ACTIVE_DEFAULT_BORDER_COLOUR As Long = &H9E8671 73 | Public Const g_lngBTN_HOVER_DEFAULT_BORDER_COLOUR As Long = &HD77800 ' Done 74 | Public Const g_lngBTN_HOVER_BORDER_COLOUR As Long = &HD77800 ' Done 75 | Public Const g_lngBTN_INACTIVE_DEFAULT_BORDER_COLOUR As Long = &HD77800 ' Done 2x width 76 | Public Const g_lngBTN_INACTIVE_BORDER_COLOUR As Long = &HADADAD ' Done 77 | 78 | Public Const g_lngBTN_ACTIVE_DEFAULT_BACKGROUND_COLOUR As Long = &HF7E4CC ' done 4x width 79 | Public Const g_lngBTN_HOVER_DEFAULT_BACKGROUND_COLOUR As Long = &HFBF1E5 ' Done 80 | Public Const g_lngBTN_HOVER_BACKGROUND_COLOUR As Long = &HFBF1E5 ' Done 81 | Public Const g_lngBTN_INACTIVE_DEFAULT_BACKGROUND_COLOUR As Long = &HE1E1E1 ' done 82 | Public Const g_lngBTN_INACTIVE_BACKGROUND_COLOUR As Long = &HE1E1E1 ' done 83 | 84 | Public Enum lctlState 85 | lctlInactive 86 | lctlHover 87 | lctlActive 88 | End Enum 89 | 90 | Public Property Let DefaultButton(ByVal stValue As String) 91 | If Mid(stValue, 1, Len(g_stLABEL_CONTROL_SUFFIX)) = g_stLABEL_CONTROL_SUFFIX Then 92 | m_stDefaultButton = stValue 93 | Else 94 | m_stDefaultButton = g_stLABEL_CONTROL_SUFFIX & stValue 95 | End If 96 | End Property 97 | 98 | Public Property Get DefaultButton() As String 99 | DefaultButton = m_stDefaultButton 100 | End Property 101 | 102 | Public Property Let ActiveButton(ByVal stValue As String) 103 | If Mid(stValue, 1, Len(g_stLABEL_CONTROL_SUFFIX)) = g_stLABEL_CONTROL_SUFFIX Then 104 | m_stActiveButton = stValue 105 | Else 106 | m_stActiveButton = g_stLABEL_CONTROL_SUFFIX & stValue 107 | End If 108 | End Property 109 | 110 | Public Property Get ActiveButton() As String 111 | ActiveButton = m_stActiveButton 112 | End Property 113 | 114 | Public Property Let TabOverflow(ByVal stValue As Long) 115 | m_lngTabOverflow = stValue 116 | End Property 117 | 118 | Public Property Get TabOverflow() As Long 119 | TabOverflow = m_lngTabOverflow 120 | End Property 121 | 122 | Public Property Let LastTabbedControl(ByVal stValue As String) 123 | m_stLastTabbedControl = stValue 124 | End Property 125 | 126 | Public Property Get LastTabbedControl() As String 127 | LastTabbedControl = m_stLastTabbedControl 128 | End Property 129 | 130 | 131 | Public Sub ModerniseForm(ByRef uUserForm As UserForm) 132 | 133 | Const sSOURCE As String = "ModerniseForm" 134 | On Error GoTo ErrorHandler 135 | 136 | uUserForm.ForeColor = g_lngFORE_COLOUR 137 | uUserForm.Font.Name = g_stFONT_NAME 138 | uUserForm.Font.Size = g_lngFONT_SIZE 139 | uUserForm.BackColor = g_lngFORM_BACK_COLOUR 140 | uUserForm.BorderColor = g_lngBORDER_COLOUR 141 | uUserForm.SpecialEffect = g_lngSPECIAL_EFFECT 142 | 143 | Exit Sub 144 | 145 | ErrorHandler: 146 | ' Run simple clean-up code here 147 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 148 | Stop 149 | Resume 150 | End If 151 | 152 | End Sub 153 | 154 | Public Sub ModerniseControls(ByRef ctlsControls As Controls) 155 | 156 | Const sSOURCE As String = "ModerniseControls" 157 | On Error GoTo ErrorHandler 158 | 159 | Dim ctlControl As Control 160 | 161 | For Each ctlControl In ctlsControls 162 | With ctlControl 163 | ' General: 164 | ' .BackColor = g_lngBACK_COLOUR 165 | 166 | Select Case TypeName(ctlControl) 167 | Case "Label" 168 | .Font.Name = g_stFONT_NAME 169 | '.Font.Size = g_lngFONT_SIZE 170 | '.ForeColor = g_lngFORE_COLOUR 171 | 172 | Case "TextBox" 173 | .Font.Name = g_stFONT_NAME 174 | .Font.Size = g_lngFONT_SIZE 175 | .BorderStyle = g_lngTEXTBOX_BORDERSTYLE 176 | .BorderColor = g_lngBORDER_COLOUR 177 | .SpecialEffect = g_lngSPECIAL_EFFECT 178 | .ForeColor = g_lngFORE_COLOUR 179 | 180 | Case "Frame" 181 | .Font.Name = g_stFONT_NAME 182 | .Font.Size = g_lngFONT_SIZE 183 | .BorderStyle = g_lngTEXTBOX_BORDERSTYLE 184 | .BorderColor = g_lngBORDER_COLOUR 185 | .SpecialEffect = g_lngSPECIAL_EFFECT 186 | .ForeColor = g_lngFORE_COLOUR 187 | 'TODO: needs work: 188 | 'ConvertToLabel ctlsControls, ctlControl 189 | 190 | Case "CheckBox" 191 | .Font.Name = g_stFONT_NAME 192 | .Font.Size = g_lngFONT_SIZE 193 | .SpecialEffect = g_lngSPECIAL_EFFECT 194 | .ForeColor = g_lngFORE_COLOUR 195 | 196 | Case "OptionButton" 197 | .Font.Name = g_stFONT_NAME 198 | .Font.Size = g_lngFONT_SIZE 199 | .SpecialEffect = g_lngSPECIAL_EFFECT 200 | .ForeColor = g_lngFORE_COLOUR 201 | 202 | Case "ScrollBar" 203 | .ForeColor = g_lngFORE_COLOUR 204 | 205 | Case "SpinButton" 206 | .ForeColor = g_lngFORE_COLOUR 207 | 208 | Case "ListBox" 209 | .Font.Name = g_stFONT_NAME 210 | .Font.Size = g_lngFONT_SIZE 211 | .SpecialEffect = g_lngSPECIAL_EFFECT 212 | .BorderStyle = g_lngTEXTBOX_BORDERSTYLE 213 | .BorderColor = g_lngBORDER_COLOUR 214 | 215 | End Select 216 | End With 217 | 218 | Next ctlControl 219 | 220 | Exit Sub 221 | 222 | ErrorHandler: 223 | ' Run simple clean-up code here 224 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 225 | Stop 226 | Resume 227 | End If 228 | 229 | End Sub 230 | 231 | Public Sub ConvertToLabel(ByRef ctlsControls As Controls, ByRef ctlControl As Control) 232 | 233 | Const sSOURCE As String = "ConvertToLabel" 234 | On Error GoTo ErrorHandler 235 | 236 | Dim ctlLabel As Control 237 | 238 | With ctlControl 239 | Set ctlLabel = ctlsControls.Add("Forms.Label.1", g_stLABEL_SUFFIX & .Name, True) 240 | 241 | Select Case TypeName(ctlControl) 242 | Case "Frame" 243 | ctlLabel.Caption = .Caption 244 | ctlLabel.Top = .Top 245 | ctlLabel.Left = .Left 246 | ctlLabel.Width = .Width 247 | ctlLabel.Height = .Height 248 | ctlLabel.BackColor = g_lngBACK_COLOUR 249 | ctlLabel.BorderStyle = fmBorderStyleSingle 250 | ctlLabel.BorderColor = g_lngOUTER_FRAME_BORDER_COLOUR 251 | ctlLabel.Font.Name = g_stFONT_NAME 252 | ctlLabel.Font.Size = g_lngFONT_SIZE 253 | ctlLabel.ForeColor = g_lngFORE_COLOUR 254 | ctlLabel.ZOrder 1 255 | End Select 256 | 257 | .Visible = False 258 | End With 259 | 260 | Exit Sub 261 | 262 | ErrorHandler: 263 | ' Run simple clean-up code here 264 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 265 | Stop 266 | Resume 267 | End If 268 | 269 | End Sub 270 | 271 | 272 | ' Removes the label command suffix. 273 | Public Function SourceButtonName(ByVal stButtonName As String) As String 274 | If Mid(stButtonName, 1, Len(g_stLABEL_CONTROL_SUFFIX)) = g_stLABEL_CONTROL_SUFFIX Then 275 | SourceButtonName = Mid(stButtonName, Len(g_stLABEL_CONTROL_SUFFIX) + 1) 276 | Else 277 | SourceButtonName = stButtonName 278 | End If 279 | End Function 280 | 281 | 282 | 'Control utilities 283 | Public Function ControlHasParent(ctlControl As Object) As Boolean 284 | 285 | On Error GoTo ErrorHandler 286 | 287 | Dim stParentType As String 288 | stParentType = TypeName(ctlControl.Parent) 289 | ControlHasParent = True 290 | 291 | Exit Function 292 | 293 | ErrorHandler: 294 | ControlHasParent = False 295 | End Function 296 | 297 | Public Sub AbsolutePosition(ByRef ctlControl As Control, ByRef dblLeft As Double, ByRef dblTop As Double) 298 | 299 | Const sSOURCE As String = "AbsolutePosition" 300 | On Error GoTo ErrorHandler 301 | 302 | dblLeft = ctlControl.Left 303 | dblTop = ctlControl.Top 304 | 305 | AbsolutePositionRecurse ctlControl, dblLeft, dblTop 306 | 307 | Exit Sub 308 | 309 | ErrorHandler: 310 | ' Run simple clean-up code here 311 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 312 | Stop 313 | Resume 314 | End If 315 | 316 | End Sub 317 | 318 | Public Sub AbsolutePositionRecurse(ByRef ctlControl As Object, ByRef dblLeft As Double, ByRef dblTop As Double) 319 | 320 | Const sSOURCE As String = "AbsolutePositionRecurse" 321 | On Error GoTo ErrorHandler 322 | 323 | If ControlHasParent(ctlControl) Then 324 | dblLeft = dblLeft + ctlControl.Parent.Left 325 | dblTop = dblTop + ctlControl.Parent.Top 326 | AbsolutePositionRecurse ctlControl.Parent, dblLeft, dblTop 327 | End If 328 | 329 | Exit Sub 330 | 331 | ErrorHandler: 332 | ' Run simple clean-up code here 333 | If bCentralErrorHandler(msMODULE, sSOURCE) Then 334 | Stop 335 | Resume 336 | End If 337 | 338 | End Sub 339 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/MainModule.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "MainModule" 2 | ' Copyright (c) Commtap CIC 2019 3 | ' Available under the MIT license: see the LICENSE file at the root of this 4 | ' project. 5 | ' Contact: tap@commtap.org 6 | 7 | Option Explicit 8 | 9 | Public Sub ShowSampleForm() 10 | 11 | Dim oUSampleUserForm As USampleUserForm 12 | Set oUSampleUserForm = New USampleUserForm 13 | oUSampleUserForm.InitiateProperties 14 | 15 | ' Modernising 16 | Set FormModerniserModule.gb_colCurrentUserForms = New Collection 17 | FormModerniserModule.gb_colCurrentUserForms.Add oUSampleUserForm 18 | FormModerniserModule.ModerniseForm oUSampleUserForm 19 | 20 | oUSampleUserForm.Show 21 | 22 | End Sub 23 | 24 | Public Sub ShowOldStyleForm() 25 | 26 | Dim oUSampleUserFormOldStyle As USampleUserFormOldStyle 27 | Set oUSampleUserFormOldStyle = New USampleUserFormOldStyle 28 | 29 | USampleUserFormOldStyle.Show 30 | 31 | End Sub 32 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/USampleUserForm.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} USampleUserForm 3 | Caption = "Sample Form" 4 | ClientHeight = 2376 5 | ClientLeft = 108 6 | ClientTop = 456 7 | ClientWidth = 4584 8 | OleObjectBlob = "USampleUserForm.frx":0000 9 | StartUpPosition = 1 'CenterOwner 10 | End 11 | Attribute VB_Name = "USampleUserForm" 12 | Attribute VB_GlobalNameSpace = False 13 | Attribute VB_Creatable = False 14 | Attribute VB_PredeclaredId = True 15 | Attribute VB_Exposed = False 16 | 17 | ' Copyright (c) Commtap CIC 2019 18 | ' Available under the MIT license: see the LICENSE file at the root of this 19 | ' project. 20 | ' Contact: tap@commtap.org 21 | 22 | Option Explicit 23 | 24 | 25 | Private p_oLabelControlsManager As CLabelControlsManager 26 | 27 | ' Click methods must be declared public 28 | Public Sub CommandButton1_Click() 29 | Me.Hide 30 | End Sub 31 | 32 | Public Sub CommandButton2_Click() 33 | MsgBox "You clicked the ""OK"" button." 34 | End Sub 35 | 36 | Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 37 | 38 | If CloseMode = vbFormControlMenu Then 39 | CommandButton1_Click 40 | Cancel = True 41 | End If 42 | 43 | End Sub 44 | 45 | ' Each form also needs one of these - this takes the hover off a button when 46 | ' the mouse is moved off it. 47 | Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 48 | p_oLabelControlsManager.LabelControls.UpdateControlButtonState 49 | End Sub 50 | 51 | Public Sub InitiateProperties() 52 | 53 | ' This styles the form generally: 54 | ModerniseControls Me.Controls 55 | 56 | ' These must be re/initialised here. 57 | FormModerniserModule.ActiveButton = vbNullString 58 | FormModerniserModule.DefaultButton = "CommandButton1" 59 | 60 | ' The order of the buttons when tabbed through. 61 | Dim arrLabelControlsOrder() As String 62 | arrLabelControlsOrder = Split("CommandButton2 CommandButton1") 63 | 64 | ' This converts command buttons into modern controls. 65 | ' The default button is the one that will run if enter is pressed. 66 | Set p_oLabelControlsManager = VFMFactory.CreateCLabelControlsManager(Me.Controls, _ 67 | arrLabelControlsOrder) 68 | 69 | End Sub 70 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/USampleUserForm.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/neilt1700/vba-form-moderniser/c5dfd863541325ed5b75dcfaae0e19037bfdecc6/vba-form-moderniser.src/USampleUserForm.frx -------------------------------------------------------------------------------- /vba-form-moderniser.src/USampleUserFormOldStyle.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} USampleUserFormOldStyle 3 | Caption = "Sample Form" 4 | ClientHeight = 2376 5 | ClientLeft = 108 6 | ClientTop = 456 7 | ClientWidth = 4584 8 | OleObjectBlob = "USampleUserFormOldStyle.frx":0000 9 | StartUpPosition = 1 'CenterOwner 10 | End 11 | Attribute VB_Name = "USampleUserFormOldStyle" 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 | 20 | Public Sub CmdCancel_Click() 21 | Me.Hide 22 | End Sub 23 | 24 | Private Sub CmdOK_Click() 25 | MsgBox "You clicked on the ""OK"" button." 26 | End Sub 27 | 28 | Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 29 | 30 | If CloseMode = vbFormControlMenu Then 31 | CmdCancel_Click 32 | Cancel = True 33 | End If 34 | 35 | End Sub 36 | 37 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/USampleUserFormOldStyle.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/neilt1700/vba-form-moderniser/c5dfd863541325ed5b75dcfaae0e19037bfdecc6/vba-form-moderniser.src/USampleUserFormOldStyle.frx -------------------------------------------------------------------------------- /vba-form-moderniser.src/VFMFactory.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VFMFactory" 2 | ' Copyright (c) Commtap CIC 2019 3 | ' Available under the MIT license: see the LICENSE file at the root of this 4 | ' project. 5 | ' Contact: tap@commtap.org 6 | 7 | Option Explicit 8 | 9 | Private Const msMODULE As String = "VFMFactory" 10 | 11 | ' Provides a way to initiate a new object with arguments. See: 12 | ' http://stackoverflow.com/questions/15224113/pass-arguments-to-constructor-in-vba 13 | 14 | ' Label Controls 15 | Public Function CreateCLabelControl(ByRef ctlsUserFormControls As MSForms.Controls, _ 16 | ByRef ctlLabelControl As MSForms.Control, _ 17 | Optional ByVal boolDefault As Boolean) As CLabelControl 18 | Set CreateCLabelControl = New CLabelControl 19 | CreateCLabelControl.InitiateProperties ctlsUserFormControls:=ctlsUserFormControls, _ 20 | ctlCommandButton:=ctlLabelControl, _ 21 | boolDefault:=boolDefault 22 | End Function 23 | 24 | Public Function CreateCLabelControlResponder(ByVal oLabelControl As CLabelControl, _ 25 | ByRef oLabelControls As CLabelControls) As CLabelControlResponder 26 | Set CreateCLabelControlResponder = New CLabelControlResponder 27 | CreateCLabelControlResponder.InitiateProperties oLabelControl:=oLabelControl, _ 28 | oLabelControls:=oLabelControls 29 | End Function 30 | 31 | Public Function CreateCLabelControlFrameResponder(ByRef ctlFrameControl As Control, _ 32 | ByRef oLabelControls As CLabelControls) As CLabelControlFrameResponder 33 | Set CreateCLabelControlFrameResponder = New CLabelControlFrameResponder 34 | CreateCLabelControlFrameResponder.InitiateProperties ctlFrameControl:=ctlFrameControl, _ 35 | oLabelControls:=oLabelControls 36 | End Function 37 | 38 | Public Function CreateCKeyDownResponder(ByRef ctlControl As Control, _ 39 | ByRef oLabelControls As CLabelControls, _ 40 | ByRef ctlsControls As Controls) As CKeyDownResponder 41 | Set CreateCKeyDownResponder = New CKeyDownResponder 42 | CreateCKeyDownResponder.InitiateProperties ctlControl:=ctlControl, _ 43 | oLabelControls:=oLabelControls, _ 44 | ctlsControls:=ctlsControls 45 | End Function 46 | 47 | Public Function CreateCLabelControls(ByRef ctlsControls As MSForms.Controls, _ 48 | ByRef arrLabelControlsOrder() As String) As CLabelControls 49 | 50 | Set CreateCLabelControls = New CLabelControls 51 | CreateCLabelControls.InitiateProperties ctlsControls:=ctlsControls, _ 52 | arrLabelControlsOrder:=arrLabelControlsOrder 53 | End Function 54 | 55 | Public Function CreateCLabelControlsManager(ByRef ctlsControls As MSForms.Controls, _ 56 | ByRef arrLabelControlsOrder() As String) As CLabelControlsManager 57 | Set CreateCLabelControlsManager = New CLabelControlsManager 58 | CreateCLabelControlsManager.InitiateProperties ctlsControls:=ctlsControls, _ 59 | arrLabelControlsOrder:=arrLabelControlsOrder 60 | End Function 61 | 62 | 63 | 64 | 65 | 66 | -------------------------------------------------------------------------------- /vba-form-moderniser.src/VFMUtility.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VFMUtility" 2 | Option Explicit 3 | 4 | ' This method from: 5 | ' https://stackoverflow.com/a/218727/1382318 6 | Public Function KeyExistsInCollection(ByVal col As Collection, ByVal key As String) As Boolean 7 | Dim Var As Variant 8 | Dim errNumber As Long 9 | 10 | KeyExistsInCollection = False 11 | Set Var = Nothing 12 | 13 | Err.Clear 14 | On Error Resume Next 15 | Var = col.Item(key) 16 | errNumber = CLng(Err.Number) 17 | On Error GoTo 0 18 | 19 | ' 5 is not in, 0 and 438 represent in collection 20 | If errNumber = 5 Then ' it is 5 if not in collection 21 | KeyExistsInCollection = False 22 | Else 23 | KeyExistsInCollection = True 24 | End If 25 | 26 | End Function 27 | 28 | Public Function ControlExists(ByVal ctlsControls As Controls, ByVal stControlName As String) As Boolean 29 | On Error Resume Next 30 | ControlExists = Not ctlsControls(stControlName) Is Nothing 31 | On Error GoTo 0 32 | End Function 33 | 34 | ' Placeholder function for error handling 35 | ' Note, general error handling is not implemented in this project, however the 36 | ' code to call it is mostly present. If you want to implement this error 37 | ' handling please refer to: 38 | ' "Professional Excel Development - Second Edition" - Rob Bovey, 39 | ' Dennis Wallentin, Stephen Bullen and John Green. 2009. Published by Addison 40 | ' Wesley. 41 | Public Function bCentralErrorHandler(ByVal sModule As String, _ 42 | ByVal sProc As String, _ 43 | Optional ByVal sFile As String, _ 44 | Optional ByVal bEntryPoint As Boolean, _ 45 | Optional ByVal bReThrow As Boolean = True) As Boolean 46 | bCentralErrorHandler = False 47 | End Function 48 | 49 | 50 | 51 | --------------------------------------------------------------------------------