應用程式 Visual Basic/使用者窗體樣式
- FormatForm() 用於使用預先選擇的顏色和字型格式化單個指定的 UserForm。這替換了之前格式化所有開啟的使用者窗體的過程。假設存在名為 UserForm1 的使用者窗體。
- 過程 AutoFormat() 為簡單的陣列資料執行自動大小調整和佈局，以便無論各種資料的長度如何，顯示和標籤欄都呈現表格外觀。此後一種過程還具有在需要時轉置輸入的功能。
更正了 Autoformat() 中的 TransposeArr2D() 的名稱。（2019 年 7 月 12 日）
用單個窗體過程 FormatForm() 替換了多窗體過程。（2019 年 1 月 18 日）
將程式碼更改為 FormatAllLoadedUserForms 中更通用的 TypeName（2018 年 6 月 28 日）
添加了轉置函式，之前省略（2017 年 6 月 10 日）
將字型過程刪除到其新頁面
減少了 AutoFormat() 控制元件的數量。（2016 年 11 月 17 日）
添加了 GetTextPoints()。（2016 年 11 月 17 日）
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