Styling User Forms

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

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