Visual Basic for Applications/Styling User Forms

Summary FormatForm() is used to format a single specified userform with pre-selected colorings and fonts. This replaces a previous procedure to format all open userforms. Assumes that a userform called UserForm1 exists. The procedure AutoFormat() performs auto-sizing and layout for simple array data, so that the display and label bar is tabular in appearance, regardless of the length of the various data. This latter procedure also has facilities to transpose the input in case it is needed. Code Modules Last Modified 10 Jun 2017 Corrected name of TransposeArr2D() in Autoformat(). (12 Jul 2019) Replaced multi-form procedure with single-form procedure FormatForm().(18 Jan 19) Changed code to more general TypeName in FormatAllLoadedUserForms(28 June 18) Added transpose function, previously omitted (10 Jun 2017) Removed font procedures to their new page Reduced number of AutoFormat() controls.(17 Nov 2016) Added GetTextPoints(). (17 Nov 2016) For Typical ThisWorkbook Module Private Sub Workbook_Open() 'Shows typical use of form format function 'runs at workbook opening 'Assumes that a user form called UserForm1 exists 'load the form Load UserForm1 'format the form FormatForm UserForm1 'show the form UserForm1.Show 'do other stuff then... 'repaint the form UserForm1.Repaint End Sub For the Standard Module Function FormatForm(vForm As Variant) As Boolean 'applies color and text formats 'to parameter user form object and its controls 'Be sure to repaint the user form after this function Dim oCont As msforms.Control Dim nColForm As Single, nColButtons As Single Dim nColBox As Single, nColLabels As Single Dim nColGenFore As Single, nColBoxText As Single 'set the color scheme here - add as required - eg: nColForm = RGB(31, 35, 44) 'main form background nColButtons = RGB(0, 128, 128) 'all button backgrounds nColGenFore = RGB(255, 255, 255) 'all button text nColBox = RGB(0, 100, 0) 'all text box backgrounds nColBoxText = RGB(255, 255, 190) 'all text box text nColLabels = RGB(23, 146, 126) 'all label text 'current user form name 'MsgBox vForm.Name 'apply user form formats here vForm.BackColor = nColForm 'apply individual control formats For Each oCont In vForm.Controls 'MsgBox oCont.Name With oCont Select Case TypeName(oCont) Case "TextBox" .BackColor = nColBox .ForeColor = nColBoxText .Font.Name = "Tahoma" .Font.Size = 8 Case "ListBox" .BackColor = nColBox .ForeColor = nColBoxText .Font.Name = "Tahoma" .Font.Size = 8 Case "ComboBox" .BackColor = nColBox .ForeColor = nColBoxText .Font.Name = "Tahoma" .Font.Size = 8 Case "Frame" .BackColor = nColForm .ForeColor = nColGenFore .Font.Name = "Tahoma" .Font.Size = 8 Case "CommandButton", "ToggleButton" .BackColor = nColButtons .ForeColor = nColGenFore .Font.Name = "Tahoma" .Font.Size = 8 Case "SpinButton" .BackColor = nColButtons .ForeColor = nColGenFore Case "OptionButton" .BackStyle = fmBackStyleTransparent .ForeColor = nColGenFore .Font.Name = "Tahoma" .Font.Size = 8 Case "CheckBox" .BackStyle = fmBackStyleTransparent .ForeColor = nColGenFore .Font.Name = "Tahoma" .Font.Size = 8 Case "Label" .BackStyle = fmBackStyleTransparent .ForeColor = nColLabels .Font.Name = "Tahoma" .Font.Size = 8 End Select End With Next oCont FormatForm = True End Function Sub AutoFormat(vA As Variant, Optional bTranspose As Boolean = False) ' Takes array vA of say, 4 columns of data and ' displays on textbox in tabular layout. ' Needs a userform called ViewVars and a textbox ' called Textbox1. Code will adjust layout. ' Transpose2DArr used only to return data to (r, c) format. Dim vB As Variant, vL As Variant, vR As Variant Dim r As Long, c As Long, m As Long, sS As String Dim nNumPadSp As Long, TxtLab As Control, MaxFormWidth As Long Dim sAccum As String, sRowAccum As String, bBold As Boolean Dim nLineLen As Long, BoxFontSize As Long, BoxFontName As String Dim sLabAccum As String, nLabPadSp As Long, oUserForm As Object Dim Backshade As Long, BoxShade As Long, BoxTextShade As Long Dim ButtonShade As Long, ButtonTextShade As Long Dim Lb1 As Long, Ub1 As Long, Lb2 As Long, Ub2 As Long Dim TextLength As Long, bItalic As Boolean ' decide to transpose input or not If bTranspose = True Then TransposeArr2D vA, vR vA = vR End If ' get bounds of display array Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1) Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2) ReDim vL(Lb2 To Ub2) ' make labels array ReDim vB(Lb2 To Ub2) ' dimension column width array '-------------------------------------------------------------- ' SET USER OPTIONS HERE '-------------------------------------------------------------- ' set the name of the userform made at design time Set oUserForm = ViewVars ' set limit for form width warning MaxFormWidth = 800 ' make column labels for userform - set empty if not needed vL = Array("Variable", "Procedure", "Module", "Project") ' colors Backshade = RGB(31, 35, 44) 'almost black - used ButtonShade = RGB(0, 128, 128) 'blue-green - not used BoxShade = RGB(0, 100, 0) 'middle green - used ButtonTextShade = RGB(230, 230, 230) 'near white - not used BoxTextShade = RGB(255, 255, 255) 'white - used ' Font details are to be found below '-------------------------------------------------------------- ' find maximum width of array columns ' taking account of label length also For c = Lb2 To Ub2 m = Len(vL(c)) 'label For r = Lb1 To Ub1 sS = vA(r, c) 'value If Len(sS) >= m Then m = Len(sS) End If Next r 'exits with col max array vB(c) = m m = 0 Next c ' For testing only ' shows max value of each column ' For c = LB2 To UB2 ' MsgBox vB(c) ' Next c For r = Lb1 To Ub1 For c = Lb2 To Ub2 If c >= Lb2 And c < Ub2 Then ' get padding for current element nNumPadSp = vB(c) + 2 - Len(vA(r, c)) Else ' get padding for last element nNumPadSp = vB(c) - Len(vA(r, c)) End If ' accumulate line with element padding sAccum = sAccum & vA(r, c) & Space(nNumPadSp) ' get typical line length If r = Lb1 Then sRowAccum = sRowAccum & vA(Lb1, c) & Space(nNumPadSp) nLineLen = Len(sRowAccum) End If Next c ' accumulate line strings sAccum = sAccum & vbNewLine Next r ' accumulate label string For c = Lb2 To Ub2 If c >= Lb2 And c < Ub2 Then ' get padding for current label nLabPadSp = vB(c) + 2 - Len(vL(c)) Else ' get padding for last element nLabPadSp = vB(c) - Len(vL(c)) End If ' accumulate the label line sLabAccum = sLabAccum & vL(c) & Space(nLabPadSp) Next c ' load user form Load oUserForm '================================================================ ' SET FONT DETAILS HERE. THESE AFFECT ALL AUTOSIZING. '================================================================ BoxFontSize = 12 'say between 6 to 20 points bBold = True 'True for bold, False for regular bItalic = False 'True for italics, False for regular BoxFontName = "Courier" 'or other monospaced fonts eg; Consolas '================================================================ ' make the labels textbox Set TxtLab = oUserForm.Controls.Add("Forms.TextBox.1", "TxtLab") ' format the labels textbox With TxtLab .WordWrap = False .AutoSize = True 'extends to fit text .Value = "" .font.Name = BoxFontName .font.SIZE = BoxFontSize .font.Bold = bBold .font.Italic = bItalic .ForeColor = BoxTextShade .Height = 20 .Left = 20 .Top = 15 .Width = 0 .BackStyle = 0 .BorderStyle = 0 .SpecialEffect = 0 End With 'apply string to test label to get length TxtLab.Value = sLabAccum & Space(2) TextLength = TxtLab.Width 'MsgBox TextLength 'format userform With oUserForm .BackColor = Backshade .Width = TextLength + 40 .Height = 340 .Caption = "Redundant variables list..." End With ' check user form is within max width If oUserForm.Width > MaxFormWidth Then MsgBox "Form width is excessive" Unload oUserForm Exit Sub End If 'format the data textbox With oUserForm.TextBox1 .ScrollBars = 3 .WordWrap = True .MultiLine = True .EnterFieldBehavior = 1 .BackColor = BoxShade .font.Name = BoxFontName .font.SIZE = BoxFontSize .font.Bold = bBold .font.Italic = bItalic .ForeColor = BoxTextShade .Height = 250 .Left = 20 .Top = 40 .Width = TextLength .Value = sAccum End With 'show the user form oUserForm.Show End Sub Function TransposeArr2D(vA As Variant, Optional vR As Variant) As Boolean '--------------------------------------------------------------------------------- ' Procedure : Transpose2DArr ' Purpose : Transposes a 2D array; rows become columns, columns become rows ' Specifically, (r,c) is moved to (c,r) in every case. ' Options include, returned in-place with the source changed, or ' if vR is supplied, returned in that instead, with the source intact. '--------------------------------------------------------------------------------- Dim vW As Variant Dim loR As Long, hiR As Long, loC As Long, hiC As Long Dim r As Long, c As Long, bWasMissing As Boolean 'find whether optional vR was initially missing bWasMissing = IsMissing(vR) If Not bWasMissing Then Set vR = Nothing 'use a work array vW = vA 'find bounds of vW data input work array loR = LBound(vW, 1): hiR = UBound(vW, 1) loC = LBound(vW, 2): hiC = UBound(vW, 2) 'set vR dimensions transposed 'Erase vR 'there must be an array in the variant to erase ReDim vR(loC To hiC, loR To hiR) 'transfer data For r = loR To hiR For c = loC To hiC 'transpose vW into vR vR(c, r) = vW(r, c) Next c Next r 'find bounds of vW data input work array ' loR = LBound(vR, 1): hiR = UBound(vR, 2) ' loC = LBound(vR, 2): hiC = UBound(vR, 2) TRANSFERS: 'decide whether to return in vA or vR If Not bWasMissing Then 'vR was the intended return array 'so leave vR as it is Else: 'vR is not intended return array 'so reload vA with vR vA = vR End If 'return success for function TransposeArr2D = True End Function