Attribute VB_Name = "basFormSize"
Option Explicit

' FormLayout()
' Resize a form and all its controls based on screen resolution.
' All controls are resized in TabIndex order. Advanced positioning lets you
' position a control based on the previous (in TabIndex order) control's
' newly resized coordinates. Set any control's Tag property to one of the
' following (without the quotes) to engage advanced positioning.
' "Fixed"
'    The control will not be resized, but it will be repositioned.
' "Multiline"
'    Some controls (Label, OptionButton, TextBox) are autosized
'    based on the font width and/or height instead of the overall ratio,
'    causing problems for multi-line controls that use word wrap. Use
'    this to skip the font-based resizing and just use generic resizing.
' "Left"
'    If the previous control is an OptionButton or CheckBox, align with
'    its caption left. This lets you align "subitems".
' "Right"
'    Position this control to the right of the previous control on the
'    same line. If the control is a TextBox and the previous control is a
'    Label, this setting will line them up vertically as well.
' "Label"
'    If the previous control is a Label, this setting will move the label down
'    slightly to align the text bottom.
' "Etched"
'    Signifies an Etched label, which simulates the etched effect on
'    disabled controls like checkboxes. To use this effect, set the main
'    label's background to transparent, add a new label with the same
'    caption, set its ForeColor to white, set its ZOrder behind the main
'    label (send to back), and set its Tag property to Etched. Be sure
'    the etched label is immediately after the main label in TabOrder.
' Parameters:
' pfrm
'    The form to be resized.
' psngFontSize can be either:
'     - The new font size for the form and all its controls. Font sizes can
'       be multiples of 0.25.
'     - A negative value (eg: -46) to calculate the new font size based on how
'       many lines of text can fit on a full screen in the current resolution.
'       46 lines (-46) results in nice compact text. 41 lines (-41) results
'       in a nice looking larger font. This is a great setting to expose to
'       the user in some way. (But don't show them negatives!)
'
' Sample usage:
'
' Private Sub Form_Load()
'     FormLayout Me
' End Sub
'
Public Sub FormLayout(pfrm As Form, Optional ByVal psngFontSize As Single = -46)
    Const Spacer = " "
    Const OptionSpacer = "o"
    Const CaptionLeftChar = " "
    Const CaptionLeftOffset = 14
    Dim sngOriginalFontSize As Single
    Dim enScaleMode As ScaleModeConstants
    Dim lngScaleLeft As Long
    Dim lngScaleTop As Long
    Dim lngScaleWidth As Long
    Dim lngScaleHeight As Long
    Dim lngLeft As Long
    Dim lngTop As Long
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim sngX As Single
    Dim sngY As Single
    Dim lngOldWidth As Long
    Dim lngOldHeight As Long
    Dim lngExtraWidth As Long
    Dim lngExtraHeight As Long
    Dim lngScreenHeight As Long
    Dim lngLines As Long
    Dim lngTabIndex() As Long
    Dim i As Long
    Dim iMax As Long
    Dim ctl As Control
    Dim ctlPrev As Control
    Dim ctlEtched As Control
    Dim lngSSTab As Long
    Dim strCaption As String
    Dim strCaptionPrev As String
    Dim lngComboHeight As Long
    
    With pfrm
        ' Remember starting font size (do nothing if it doesn't end up changing)
        sngOriginalFontSize = .FontSize
        ' Save scale settings so we can set ScaleMode to Twips, greatly simplifying things
        enScaleMode = .ScaleMode
        If enScaleMode = vbUser Then
            lngScaleLeft = .ScaleLeft
            lngScaleTop = .ScaleTop
            lngScaleWidth = .ScaleWidth
            lngScaleHeight = .ScaleHeight
        End If
        .ScaleMode = vbTwips
        ' Get existing dimensions
        lngOldWidth = .TextWidth(Spacer)
        lngOldHeight = .TextHeight(Spacer)
        lngExtraWidth = .Width - .ScaleWidth
        lngExtraHeight = .Height - .ScaleHeight
        ' Calculate new font size based on lines of text per screen
        If psngFontSize < 0 Then
            lngLines = Abs(psngFontSize)
            lngScreenHeight = Screen.Height
            .FontSize = 6 ' Arbitrary minimum size
            ' Grow font until the screen holds < requested number of lines (one size too big)
            ' (psngFontSize retains the previous value, so it'll end up with the correct size)
            Do
                psngFontSize = .FontSize
                ' Font sizes have erratic increments; identify the next size up
                .FontSize = .FontSize + 0.25
                If psngFontSize = .FontSize Then .FontSize = .FontSize + 0.5
                If psngFontSize = .FontSize Then .FontSize = .FontSize + 0.75
                If psngFontSize = .FontSize Then .FontSize = .FontSize + 1
                If psngFontSize = .FontSize Then Exit Do
            Loop Until lngScreenHeight \ .TextHeight(Spacer) < lngLines
        End If
        ' Commit to the new font size
        .FontSize = psngFontSize
    End With
    ' Do nothing if font size hasn't changed
    If pfrm.FontSize <> sngOriginalFontSize Then
        With pfrm
            ' Calculate ratios based on change in font size
            sngX = .TextWidth(Spacer) / lngOldWidth
            sngY = .TextHeight(Spacer) / lngOldHeight
            ' Resize form
            lngWidth = .ScaleWidth * sngX + lngExtraWidth
            lngHeight = .ScaleHeight * sngY + lngExtraHeight
            ' Center form if it was already centered, otherwise don't move it
            If .Left <> (Screen.Width - .Width) \ 2 Then lngLeft = .Left Else lngLeft = (Screen.Width - lngWidth) \ 2
            If .Top <> (Screen.Height - .Height) \ 2 Then lngTop = .Top Else lngTop = (Screen.Height - lngHeight) \ 2
            .Move lngLeft, lngTop, lngWidth, lngHeight
            ' Identify TabIndex order
            iMax = .Controls.Count - 1
        End With
        If iMax >= 0 Then
            ReDim lngTabIndex(iMax)
            For Each ctl In pfrm.Controls
                ' Resize lines & shapes now because they don't have a TabIndex
                With ctl
                    Select Case TypeName(ctl)
                        Case "Line"
                            ' Identify left offset (used for controls on an inactive SSTab tab)
                            If TypeName(.Container) = "SSTab" And .X1 < -1500 Then lngSSTab = 75000 Else lngSSTab = 0
                            .X1 = (.X1 + lngSSTab) * sngX - lngSSTab
                            .X2 = (.X2 + lngSSTab) * sngX - lngSSTab
                            .Y1 = .Y1 * sngY
                            .Y2 = .Y2 * sngY
                            iMax = iMax - 1
                        Case "Shape", "Image"
                            ' Identify left offset (used for controls on an inactive SSTab tab)
                            If TypeName(.Container) = "SSTab" And .Left < -1500 Then lngSSTab = 75000 Else lngSSTab = 0
                            .Move (.Left + lngSSTab) * sngX - lngSSTab, .Top * sngY, .Width * sngX, .Height * sngY
                            iMax = iMax - 1
                        Case Else
                            On Error Resume Next
                            lngTabIndex(.TabIndex) = i
                            If Err.Number <> 0 Then iMax = iMax - 1
                            On Error GoTo 0
                            ' Identify ComboBox height
                            If TypeOf ctl Is ComboBox And lngComboHeight = 0 Then
                                .FontSize = pfrm.FontSize
                                lngComboHeight = ctl.Height
                            End If
                    End Select
                End With
                i = i + 1
            Next
            ' Identify standard textbox height now to speed up loop
            If lngComboHeight = 0 Then lngComboHeight = pfrm.TextHeight(Spacer) + 4 * Screen.TwipsPerPixelY
            ' Iterate controls in TabIndex order
            For i = 0 To iMax
                Set ctl = pfrm.Controls(lngTabIndex(i))
                Select Case TypeName(ctl)
                    Case "OptionButton", "CheckBox": strCaption = Replace(Replace(Replace(ctl.Caption, "&&", "~"), "&", ""), "~", "&")
                End Select
                If i <> 0 Then
                    Set ctlPrev = pfrm.Controls(lngTabIndex(i - 1))
                    Select Case TypeName(ctlPrev)
                        Case "OptionButton", "CheckBox": strCaptionPrev = Replace(Replace(Replace(ctlPrev.Caption, "&&", "~"), "&", ""), "~", "&")
                    End Select
                    If ctl.Tag = "Etched" Then Set ctlEtched = pfrm.Controls(lngTabIndex(i - 1))
                End If
                With ctl
                    ' Identify left offset (used for controls on an inactive SSTab tab)
                    If TypeName(.Container) = "SSTab" And .Left < -1500 Then lngSSTab = 75000 Else lngSSTab = 0
                    ' Identify current dimensions
                    lngLeft = .Left + lngSSTab
                    lngTop = .Top
                    lngWidth = .Width
                    lngHeight = .Height
                    ' LEFT
                    Select Case .Tag
                        Case "Left"
                            Select Case TypeName(ctlPrev)
                                Case "OptionButton", "CheckBox": lngLeft = ctlPrev.Left + CaptionLeftOffset * Screen.TwipsPerPixelX + pfrm.TextWidth(CaptionLeftChar)
                                Case Else: lngLeft = ctlPrev.Left
                            End Select
                        Case "Right"
                            Select Case TypeName(ctlPrev)
                                Case "OptionButton", "CheckBox": lngLeft = ctlPrev.Left + (CaptionLeftOffset + 1) * Screen.TwipsPerPixelX + pfrm.TextWidth(strCaptionPrev) + pfrm.TextWidth(OptionSpacer)
                                Case Else: lngLeft = ctlPrev.Left + ctlPrev.Width + pfrm.TextWidth(Spacer)
                            End Select
                        Case "Etched": lngLeft = ctlPrev.Left + Screen.TwipsPerPixelX
                        Case Else: lngLeft = lngLeft * sngX
                    End Select
                    ' TOP
                    Select Case .Tag
                        Case "Etched": lngTop = ctlPrev.Top + Screen.TwipsPerPixelY
                        Case Else: lngTop = lngTop * sngY
                    End Select
                    ' WIDTH
                    Select Case .Tag
                        Case "Fixed"
                        Case "MultiLine": lngWidth = lngWidth * sngX
                        Case "Etched": lngWidth = ctlPrev.Width
                        Case Else
                            Select Case TypeName(ctl)
                                Case "OptionButton", "CheckBox": lngWidth = CaptionLeftOffset * Screen.TwipsPerPixelX + 2 * pfrm.TextWidth(CaptionLeftChar) + pfrm.TextWidth(strCaption)
                                Case "TextBox": If .MaxLength <> 0 Then lngWidth = pfrm.TextWidth("8") * (.MaxLength + 1) Else lngWidth = lngWidth * sngX
                                Case Else: lngWidth = lngWidth * sngX
                            End Select
                    End Select
                    ' HEIGHT
                    Select Case .Tag
                        Case "Fixed"
                        Case "MultiLine": lngHeight = lngHeight * sngY
                        Case "Etched": lngHeight = ctlPrev.Height
                        Case Else
                            Select Case TypeName(ctl)
                                Case "OptionButton", "CheckBox": lngHeight = lngComboHeight
                                Case "ListBox"
                                    lngLines = ctl.Height \ lngOldHeight
                                    lngHeight = pfrm.TextHeight(Spacer) * lngLines + ctl.Height - (lngLines * lngOldHeight)
                                Case "TextBox": lngHeight = lngComboHeight
                                Case Else: lngHeight = lngHeight * sngY
                            End Select
                    End Select
                    ' Apply new formatting
                    On Error Resume Next
                    .Font.Size = pfrm.FontSize
                    On Error GoTo 0
                    Select Case TypeName(ctl)
                        Case "Label"
                            Select Case .Tag
                                Case "MultiLine", "Etched"
                                Case Else
                                    .AutoSize = True
                                    lngHeight = .Height
                                    Select Case .Alignment
                                        Case vbRightJustify: If lngWidth < .Width Then lngLeft = lngLeft - (.Width - lngWidth)
                                        Case vbCenter: If lngWidth < .Width Then lngLeft = lngLeft - (.Width - lngWidth) \ 2
                                    End Select
                                    lngWidth = .Width
                            End Select
                            .Move lngLeft, lngTop, lngWidth, lngHeight
                        Case "ComboBox"
                            lngComboHeight = .Height
                            .Move lngLeft, lngTop, lngWidth
                        Case Else
                            .Move lngLeft, lngTop, lngWidth, lngHeight
                    End Select
                    ' Check for vertical align
                    If i <> 0 Then
                        If TypeOf ctlPrev Is Label Then
                            Select Case .Tag
                                Case "Label", "Right"
                                    ' If previous control is an Etched label, move both labels
                                    If ctlPrev.Tag = "Etched" Then
                                        ctlEtched.Top = ctl.Top + 3 * Screen.TwipsPerPixelY
                                        ctlPrev.Top = ctlEtched.Top + Screen.TwipsPerPixelY
                                    Else
                                        ctlPrev.Top = ctl.Top + 3 * Screen.TwipsPerPixelY
                                    End If
                            End Select
                        End If
                    End If
                End With
                Set ctl = Nothing
            Next
            Set ctlPrev = Nothing
            Set ctlEtched = Nothing
        End If
    End If
    ' Reset ScaleMode to original settings
    With pfrm
        If enScaleMode = vbUser Then
            .ScaleLeft = lngScaleLeft
            .ScaleTop = lngScaleTop
            .ScaleWidth = lngScaleWidth
            .ScaleHeight = lngScaleHeight
        Else
            .ScaleMode = enScaleMode
        End If
    End With
End Sub

Public Function GetFontSize(pfrm As Form, Optional pblnLarge As Boolean = False) As Single
    Const Char = "Q"
    Dim sngOriginal As Single
    Dim sngFontSize As Single
    Dim lngHeight As Long
    Dim lngMin As Long
    Dim lngLines As Long
    Dim lngTwips As Long
    
    If pblnLarge Then lngMin = 46 Else lngMin = 46
    With Screen
        lngHeight = .Height \ .TwipsPerPixelY
    End With
    With pfrm
        If .ScaleMode = vbPixels Then lngTwips = 1 Else lngTwips = Screen.TwipsPerPixelY
        sngOriginal = .FontSize
        .FontSize = 6
        Do
            sngFontSize = .FontSize
            .FontSize = .FontSize + 0.25
            If sngFontSize = .FontSize Then .FontSize = .FontSize + 0.5
            If sngFontSize = .FontSize Then .FontSize = .FontSize + 0.75
            If sngFontSize = .FontSize Then .FontSize = .FontSize + 1
            lngLines = lngHeight \ (.TextHeight(Char) \ lngTwips)
        Loop Until lngLines < lngMin
        .FontSize = sngOriginal
    End With
    GetFontSize = sngFontSize
End Function

Public Function GetOptionCaptionLeft(popt As OptionButton) As Long
    Const Pixels = 15
    Const Char = " "
    
    GetOptionCaptionLeft = popt.Left + Pixels * Screen.TwipsPerPixelX + popt.Parent.TextWidth(Char)
End Function

Public Function GetOptionHeight(popt As OptionButton) As Long
    Const Pixels = 4
    Const Char = "Q"
    
    With popt.Parent
        GetOptionHeight = Pixels * Screen.TwipsPerPixelX + .TextHeight(Char)
    End With
End Function

Public Function GetOptionRight(popt As OptionButton) As Long
    Const Pixels = 15
    Const Char = " "
    Dim strCaption As String
    
    strCaption = popt.Caption & Char
    strCaption = Replace(strCaption, "&&", "~")
    strCaption = Replace(strCaption, "&", "")
    strCaption = Replace(strCaption, "~", "&")
    With popt.Parent
        GetOptionRight = popt.Left + Pixels * Screen.TwipsPerPixelX + .TextWidth(strCaption)
    End With
End Function

Public Function GetOptionWidth(popt As OptionButton) As Long
    Const Pixels = 14
    Const Char = "  "
    Dim strCaption As String
    
    strCaption = popt.Caption & Char
    strCaption = Replace(strCaption, "&&", "~")
    strCaption = Replace(strCaption, "&", "")
    strCaption = Replace(strCaption, "~", "&")
    With popt.Parent
        GetOptionWidth = Pixels * Screen.TwipsPerPixelX + .TextWidth(strCaption)
    End With
End Function

Public Function OptionButtonCaptionLeft(popt As OptionButton) As Long
    Const Pixels = 14
    Const Char = " "
    
    OptionButtonCaptionLeft = popt.Left + (Pixels * Screen.TwipsPerPixelX) + popt.Parent.TextWidth(Char)
End Function

Public Function StripAcceleratorKeys(pstrCaption As String) As String
    Dim strReturn As String
    
    strReturn = pstrCaption
    strReturn = Replace(strReturn, "&&", "~")
    strReturn = Replace(strReturn, "&", "")
    strReturn = Replace(strReturn, "~", "&")
    StripAcceleratorKeys = strReturn
End Function