Attribute VB_Name = "modScaleForm"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If you can read "Attribute VB_Name = "modScaleForm"" on the line above when already in the
' Access VBA editor, please remove this line or the module will not compile.
' When importing the .bas-file the the "import from file" function, this line never appears
' and the module is already correctly named "modScaleForm"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GENERAL INFORMATION
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Module     : modScaleForm
' Version    : 2008-01-21
' Usable     : From Access 2002 (XP) and up, maybe from Access 2000 and up
' Author     : Markus Gruber (markus.gruber@gruber.cc)
' Purpose    : Resize Access forms and scale the controls within according to screen resolution
'              and DPI.
' Usage      : 1) Add "ScaleFormWindow Me" to the OnOpen-Event of all your forms. When setting
'                 the optional parameter "DoNotScaleFormProportionally" to true, the window
'                 does not scale to the same ratio horizontally and vertically, but strict to
'                 the ratios between design resolution and current resolution. This may lead to
'                 unproportionally scaled forms and controls.
'              2) Add "ScaleFormControls Me" to the OnResize-Event of all your forms.
'              1+2) (You can also use the function "InitialInsertCodeIntoForms" to do this initially.
'                   Watch the "immediate window".)
'              3) Set the following constants in the module to match your design environment:
'                 DefaultDesignWidth (default is 1280)
'                 DefaultDesignHeight (default is 1024)
'                 DefaultDesignDPI (default is 120)
'              4) If one form was designed at another resolution, add the following to the
'                 form's tag field (do not forget all the ":"):
'                 DesignRes:<width>x<height>x<DPI>: - for example:
'                 DesignRes:1024x768x96:
' Credits    : .) Thanks to Jamie Czernik for his module modResizeForm, it was much inspiration!
'              .) Thanks to Myke Mayers for his function AdjustColumnWidths, it helped me a lot!
' Requires   : :) This module needs the class module clFormWindow:
'                 Visit http://www.mvps.org/access/forms/frm0042.htm
'                 and download http://www.mvps.org/access/downloads/clFormWindow.bas
' Remarks    : .) I am pretty sure that there are many errors in this module. Feel free
'                 to correct them yourself or simply inform me about them.
'              .) This module is provided "as is", I do not take responsability for usage.
'              .) This module is licensed under the GPL.
'              .) Thanks to all other Access developers posting solutions and code helping me
'                 over the last years!
' Remarks 2  : .) Resizing (sub)forms with many controls takes long (I know of a case, where it
'                 takes 15 seconds).
'              .) Fonts are sized using the smaller value of either horizontal or vertical scale
'                 factor - if this would not be the case, fonts would not fit any more into
'                 their controls.
'              .) Windows are centered after rescaling, so that they can not "disappear" to
'                 non-visible areas. Therefore, I use the class module "clFormWindow". If you only
'                 want the module to set the new size but not center the form, set the optional
'                 parameter "DoNotCenterForm" to "true".
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' CHANGELOG
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 2008-02-02: .) Added a comment about a possible caveat with the line
'                "Attribute VB_Name = "modScaleForm"". Thanks to Tony D'Ambra from
'                www.accessextra.net for the information!
'             .) Added description about optional parameter "DoNotScaleFormProportionally".
'             .) Added description about font sizing behavior.
'             .) Added description why I use clFormWindow for setting a form's position.
'             .) New optional parameter "DoNotCenterForm".
'
' 2008-01-21: .) Fixed a bug at scaling column widths
'
' 2008-01-18: .) First control element returned from Access has been been included in array (missing
'                "ReDim Preserve" added)
'
' 2008-01-07: .) DPI changes are reflected in scale factors
'             .) Added function "InitialInsertCodeIntoForms"
'
' 2007-12-01: .) Split ModScaleForm in several functions
'
' 2007-11-01: .) First thoughts and research
'             .) Decision to create modScaleForm
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



Option Compare Database
Option Explicit

Private Type tRect 'for window sizes
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type tControl 'for control properties
    FormName As String
    NAME As String
    Height As Long
    Width As Long
    Top As Long
    Left As Long
    FontSize As Long
    ColumnWidths As String
    ListWidth As Long
    TabFixedWidth As Long
    TabFixedHeight As Long
End Type

Private Type tDisplay
    Height As Long
    Width As Long
    DPI As Long
End Type


Private Const DefaultDesignWidth As Long = 1280
Private Const DefaultDesignHeight As Long = 1024
Private Const DefaultDesignDPI As Long = 120
Private Const WM_HORZRES As Long = 8
Private Const WM_VERTRES As Long = 10
Private Const WM_LOGPIXELSX As Long = 88


Private Declare Function WM_apiGetDC Lib "user32" Alias "GetDC" (ByVal hWnd As Long) As Long

Private Declare Function WM_apiReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal hWnd As Long, ByVal hdc As Long) As Long

Private Declare Function WM_apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Declare Function WM_apiGetWindowRect Lib "user32.dll" Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As tRect) As Long 'for getting window sizes


Public arrCtlsScaleForm() As tControl 'public array for control properties, available for all forms

Public Sub ScaleFormWindow(ByVal frm As Access.Form, Optional DoNotScaleFormProportionally As Boolean, Optional DoNotCenterForm As Boolean)

Dim rectWindow As tRect
Dim ScaleVertFactor As Single
Dim ScaleHorzFactor As Single
Dim ScaleFontFactor As Single
Dim TagString As String
Dim TagStringPosition As Long
Dim TagStringArray() As String
Dim ArrayCount As Long
Dim OnOpenWindowWidth As Long
Dim OnOpenWindowHeight As Long
Dim ctl As Control
Dim CurrentFormWidth As Long
Dim CurrentFormHeight As Long
Dim arrCtlsScaleFormTemp() As tControl
Dim TempVar As Variant
Dim hDCcaps As Long
Dim lngRtn As Long
Dim GetScreenResolution As tDisplay
Dim CurrentScreenWidth As Long
Dim CurrentScreenHeight As Long
Dim CurrentScreenDPI As Long
Dim DesignResDPI As Long
Dim DesignResWidth As Long
Dim DesignResHeight As Long
Dim MonitorResHeightRatio As Single
Dim MonitorResWidthRatio As Single
Dim NewForm As New clFormWindow
Dim NewFormHeight As Long
Dim NewFormWidth As Long


On Error Resume Next

If isSubform(frm) Then
    Exit Sub
Else
    'go go go
End If


'Set size to fit form
DoCmd.RunCommand acCmdSizeToFitForm


'Extract "DesignRes:*:" from Tag-Option of Form
TagString = LCase(frm.Tag) 'lower case tag-field
TagStringPosition = InStr(TagString, "designres:") 'get left position of resolution
If TagStringPosition > 0 Then
    TagString = Mid(TagString, TagStringPosition + 10) 'get string starting with resolution (the "+10" is the char count of "OnOpenRes:"
    TagStringPosition = InStr(TagString, ":") 'Get Position of ":" behind resolution
    TagString = Left(TagString, TagStringPosition - 1) 'remove everything behind ":" - the variable now contains the OnOpen resolution
    ReDim TagStringArray(1)
    TagStringArray = Split(TagString, "x") '"x" is the delimiter
    If UBound(TagStringArray) >= 0 Then DesignResWidth = TagStringArray(0)
    If UBound(TagStringArray) >= 1 Then DesignResHeight = TagStringArray(1)
    If UBound(TagStringArray) >= 2 Then DesignResDPI = TagStringArray(2)
    If (DesignResWidth <= 0) Or (DesignResHeight <= 0) Or (DesignResDPI <= 0) Then
        DesignResWidth = DefaultDesignWidth
        DesignResHeight = DefaultDesignHeight
        DesignResDPI = DefaultDesignDPI
    End If
    Erase TagStringArray
Else
    'DesignRes is not specified in the form so we use default values for scaling
    DesignResWidth = DefaultDesignWidth
    DesignResHeight = DefaultDesignHeight
    DesignResDPI = DefaultDesignDPI
End If


TagString = LCase(frm.Tag) 'lower case tag-field
TagStringPosition = InStr(TagString, "onopenres:") 'get left position of resolution
If TagStringPosition > 0 Then
    TagString = Mid(TagString, TagStringPosition + 10) 'get string starting with resolution (the "+10" is the char count of "OnOpenRes:"
    TagStringPosition = InStr(TagString, ":") 'Get Position of ":" behind resolution
    TagString = Left(TagString, TagStringPosition - 1) 'remove everything behind ":" - the variable now contains the OnOpen resolution
    ReDim TagStringArray(1)
    TagStringArray = Split(TagString, "x") '"x" is the delimiter
    OnOpenWindowWidth = TagStringArray(0)
    OnOpenWindowHeight = TagStringArray(1)
    Erase TagStringArray
Else
    Call WM_apiGetWindowRect(frm.hWnd, rectWindow) 'prepare for getting size of current window on screen
    OnOpenWindowWidth = rectWindow.Right - rectWindow.Left
    OnOpenWindowHeight = rectWindow.Bottom - rectWindow.Top
    frm.Tag = frm.Tag & ", OnOpenRes:" & OnOpenWindowWidth & "x" & OnOpenWindowHeight & ":"
End If


'Call API to get current resolution
hDCcaps = WM_apiGetDC(0) 'Get display context for desktop (hwnd = 0).
With GetScreenResolution
    .Height = WM_apiGetDeviceCaps(hDCcaps, WM_VERTRES)
    .Width = WM_apiGetDeviceCaps(hDCcaps, WM_HORZRES)
    .DPI = WM_apiGetDeviceCaps(hDCcaps, WM_LOGPIXELSX)
End With
lngRtn = WM_apiReleaseDC(0, hDCcaps) 'Release display context.


CurrentScreenWidth = GetScreenResolution.Width
CurrentScreenHeight = GetScreenResolution.Height
CurrentScreenDPI = GetScreenResolution.DPI


If (DesignResDPI = CurrentScreenDPI) And (DesignResWidth = CurrentScreenWidth) And (DesignResHeight = CurrentScreenHeight) Then
    'design values match current values
    Exit Sub
Else
    'design values and current values arenot equal, go on
End If


'Calculate Ratios
MonitorResHeightRatio = (CurrentScreenHeight / DesignResHeight) * (DesignResDPI / CurrentScreenDPI)
MonitorResWidthRatio = (CurrentScreenWidth / DesignResWidth) * (DesignResDPI / CurrentScreenDPI)


'If DoNotScaleFormProportionally is True, then the ratios remain the same. Else, the smaller value is chosen for both
If DoNotScaleFormProportionally = False Then
    If MonitorResHeightRatio < MonitorResWidthRatio Then MonitorResWidthRatio = MonitorResHeightRatio
    If MonitorResWidthRatio < MonitorResHeightRatio Then MonitorResHeightRatio = MonitorResWidthRatio
Else
    'leave ratios as they are and scale unproportionally, strictly as display resolution ratios are.
End If


'Get width and heights of form
Call WM_apiGetWindowRect(frm.hWnd, rectWindow) 'prepare for getting size of current window on screen
CurrentFormWidth = rectWindow.Right - rectWindow.Left
CurrentFormHeight = rectWindow.Bottom - rectWindow.Top


'Calculate new width and height (add 1 pixel for safety reasons), including percentage relative to whole desktop
NewFormHeight = Round(CurrentFormHeight * MonitorResHeightRatio, 0) '+ 1
NewFormWidth = Round(CurrentFormWidth * MonitorResWidthRatio, 0) '+ 1


'Set form's new size and position
NewForm.hWnd = frm.hWnd
With NewForm
    .Height = NewFormHeight
    .Width = NewFormWidth
End With
'If DoNotCenterForm is True, then the form is not centered
If DoNotCenterForm = False Then
    With NewForm
        .Top = (.Parent.Height - NewFormHeight) / 2
        .Left = (.Parent.Width - NewFormWidth) / 2
    End With
Else
    'form should not be centered
End If
Set NewForm = Nothing


End Sub

Public Sub ScaleFormControls(ByVal frm As Access.Form, Optional NoScalingWhenSubform As Boolean)

Dim rectWindow As tRect
Dim ScaleVertFactor As Single
Dim ScaleHorzFactor As Single
Dim ScaleFontFactor As Single
Dim TagString As String
Dim TagStringPosition As Long
Dim TagStringArray() As String
Dim ArrayCount As Long
Dim OnOpenWindowWidth As Long
Dim OnOpenWindowHeight As Long
Dim ctl As Control
Dim CurrentWindowWidth As Long
Dim CurrentWindowHeight As Long
Dim arrCtlsScaleFormTemp() As tControl
Dim FormExists As Boolean
Dim hDCcaps As Long
Dim lngRtn As Long
Dim GetScreenResolution As tDisplay
Dim CurrentScreenWidth As Long
Dim CurrentScreenHeight As Long
Dim CurrentScreenDPI As Long
Dim DesignResDPI As Long
Dim FormMaxDimension As Long
Dim HeaderVisible As Boolean
Dim FooterVisible As Boolean
Dim DetailVisible As Boolean
Dim LastScaleHorzFactor As Single
Dim LastScaleVertFactor As Single


On Error Resume Next 'no error messages, no debugger will start

'prepare array holding initial control sizes
If (Not arrCtlsScaleForm) = -1 Then
    'array empty, so create one
    ReDim arrCtlsScaleForm(1) 'create array
Else
    'array exists, do nothing
End If


If isSubform(frm) And (NoScalingWhenSubform = True) Then
    Exit Sub
Else
    'go go go
End If


TagString = LCase(frm.Tag) 'lower case tag-field
TagStringPosition = InStr(TagString, "onopenres:") 'get left position of resolution
If TagStringPosition > 0 Then
    TagString = Mid(TagString, TagStringPosition + 10) 'get string starting with resolution (the "+10" is the char count of "OnOpenRes:"
    TagStringPosition = InStr(TagString, ":") 'Get Position of ":" behind resolution
    TagString = Left(TagString, TagStringPosition - 1) 'remove everything behind ":" - the variable now contains the OnOpen resolution
    ReDim TagStringArray(1)
    TagStringArray = Split(TagString, "x") '"x" is the delimiter
    OnOpenWindowWidth = TagStringArray(0)
    OnOpenWindowHeight = TagStringArray(1)
    Erase TagStringArray
Else
    Call WM_apiGetWindowRect(frm.hWnd, rectWindow) 'prepare for getting size of current window on screen
    OnOpenWindowWidth = rectWindow.Right - rectWindow.Left
    OnOpenWindowHeight = rectWindow.Bottom - rectWindow.Top
    frm.Tag = frm.Tag & ", OnOpenRes:" & OnOpenWindowWidth & "x" & OnOpenWindowHeight & ":"
End If


'check if form has already been opened and is part of the array
'if not, write the propertie to the array
FormExists = 0 'means name of form is not in the array, initially
For ArrayCount = LBound(arrCtlsScaleForm) To UBound(arrCtlsScaleForm)
    If arrCtlsScaleForm(ArrayCount).FormName = frm.NAME Then FormExists = 1 'form name is already in the array, no need to write array
Next ArrayCount


If FormExists = 0 Then
    ArrayCount = UBound(arrCtlsScaleForm) + 1
    ReDim Preserve arrCtlsScaleForm(ArrayCount) 'Increase the size of the array.
    For Each ctl In frm.Controls
        With arrCtlsScaleForm(ArrayCount)
            .FormName = frm.NAME
            .NAME = ctl.NAME
            .Height = ctl.Height
            .Width = ctl.Width
            .Top = ctl.Top
            .Left = ctl.Left
            .FontSize = ctl.FontSize
            .ColumnWidths = ctl.ColumnWidths
            .ListWidth = ctl.ListWidth
            .TabFixedWidth = ctl.TabFixedWidth
            .TabFixedHeight = ctl.TabFixedHeight
        End With
        ArrayCount = ArrayCount + 1
        ReDim Preserve arrCtlsScaleForm(ArrayCount) 'Increase the size of the array.
    Next ctl
    'save initial heights for header, detail, footer
    ArrayCount = UBound(arrCtlsScaleForm) + 1
    ReDim Preserve arrCtlsScaleForm(ArrayCount)
    With arrCtlsScaleForm(ArrayCount)
        .FormName = frm.NAME
        .NAME = "xxxHeaderxxx"
        .Height = frm.Section(Access.acHeader).Height
    End With
    ArrayCount = ArrayCount + 1
    ReDim Preserve arrCtlsScaleForm(ArrayCount)
    With arrCtlsScaleForm(ArrayCount)
        .FormName = frm.NAME
        .NAME = "xxxDetailxxx"
        .Height = frm.Section(Access.acDetail).Height
    End With
    ArrayCount = ArrayCount + 1
    ReDim Preserve arrCtlsScaleForm(ArrayCount)
    With arrCtlsScaleForm(ArrayCount)
        .FormName = frm.NAME
        .NAME = "xxxFooterxxx"
        .Height = frm.Section(Access.acFooter).Height
    End With
    ArrayCount = ArrayCount + 1
    ReDim Preserve arrCtlsScaleForm(ArrayCount)
    With arrCtlsScaleForm(ArrayCount)
        .FormName = frm.NAME
        .NAME = "xxxLastScaleVertFactorxxx"
        .Height = 1
    End With
    ArrayCount = ArrayCount + 1
    ReDim Preserve arrCtlsScaleForm(ArrayCount)
    With arrCtlsScaleForm(ArrayCount)
        .FormName = frm.NAME
        .NAME = "xxxLastScaleHorzFactorxxx"
        .Height = 1
    End With
End If


Call WM_apiGetWindowRect(frm.hWnd, rectWindow) 'prepare for getting size of current window on screen
CurrentWindowWidth = rectWindow.Right - rectWindow.Left
CurrentWindowHeight = rectWindow.Bottom - rectWindow.Top


For ArrayCount = LBound(arrCtlsScaleForm) To UBound(arrCtlsScaleForm)
    If arrCtlsScaleForm(ArrayCount).FormName = frm.NAME Then
        Select Case arrCtlsScaleForm(ArrayCount).NAME
            Case "xxxLastScaleHorzFactorxxx"
               LastScaleHorzFactor = arrCtlsScaleForm(ArrayCount).Height
            Case "xxxLastScaleVertFactorxxx"
                LastScaleVertFactor = arrCtlsScaleForm(ArrayCount).Height
        End Select
    End If
Next


'Calculate the scaling factors and round them to 2 decimal places.
'This ensures that changes happen only in the area of 1% relative to the original size
ScaleVertFactor = Round((CurrentWindowHeight / OnOpenWindowHeight), 2)
ScaleHorzFactor = Round((CurrentWindowWidth / OnOpenWindowWidth), 2)
ScaleFontFactor = VBA.IIf(ScaleHorzFactor < ScaleVertFactor, ScaleHorzFactor, ScaleVertFactor)

If (ScaleVertFactor = LastScaleVertFactor) And (ScaleHorzFactor = LastScaleHorzFactor) Then
    'nothing to rescale
    Exit Sub
Else
    'there is something to rescale, so we update the array
    For ArrayCount = LBound(arrCtlsScaleForm) To UBound(arrCtlsScaleForm)
        If arrCtlsScaleForm(ArrayCount).FormName = frm.NAME Then
            Select Case arrCtlsScaleForm(ArrayCount).NAME
                Case "xxxLastScaleHorzFactorxxx"
                    arrCtlsScaleForm(ArrayCount).Height = ScaleHorzFactor
                Case "xxxLastScaleVertFactorxxx"
                    arrCtlsScaleForm(ArrayCount).Height = ScaleVertFactor
            End Select
        End If
    Next
End If



frm.Painting = False 'Turn off painting


For ArrayCount = LBound(arrCtlsScaleForm) To UBound(arrCtlsScaleForm)
    If arrCtlsScaleForm(ArrayCount).FormName = frm.NAME Then
        Select Case arrCtlsScaleForm(ArrayCount).NAME
            Case "xxxHeaderxxx"
                frm.Section(Access.acHeader).Height = arrCtlsScaleForm(ArrayCount).Height * ScaleVertFactor
            Case "xxxDetailxxx"
                frm.Section(Access.acDetail).Height = arrCtlsScaleForm(ArrayCount).Height * ScaleVertFactor
            Case "xxxFooterxxx"
                frm.Section(Access.acFooter).Height = arrCtlsScaleForm(ArrayCount).Height * ScaleVertFactor
        End Select
    End If
Next ArrayCount


For ArrayCount = LBound(arrCtlsScaleForm) To UBound(arrCtlsScaleForm)
    If (arrCtlsScaleForm(ArrayCount).FormName = frm.NAME) And (arrCtlsScaleForm(ArrayCount).NAME <> "") Then
        'On Error GoTo err
        If frm.Controls.Item(arrCtlsScaleForm(ArrayCount).NAME).ControlType <> Access.acPage Then  'Ignore pages in Tab controls.
            With frm.Controls.Item(arrCtlsScaleForm(ArrayCount).NAME)
                If ScaleVertFactor <> LastScaleVertFactor Then
                    .Height = arrCtlsScaleForm(ArrayCount).Height * ScaleVertFactor
                    .Top = arrCtlsScaleForm(ArrayCount).Top * ScaleVertFactor
                End If
                If ScaleHorzFactor <> LastScaleHorzFactor Then
                    .Left = arrCtlsScaleForm(ArrayCount).Left * ScaleHorzFactor
                    .Width = arrCtlsScaleForm(ArrayCount).Width * ScaleHorzFactor
                End If
                If .FontSize > 0 Then
                    .FontSize = arrCtlsScaleForm(ArrayCount).FontSize * ScaleFontFactor
                End If
                Select Case frm.Controls.Item(arrCtlsScaleForm(ArrayCount).NAME).ControlType
                    Case Access.acListBox
                        .ColumnWidths = ScaleColumnWidths(arrCtlsScaleForm(ArrayCount).ColumnWidths, ScaleHorzFactor)
                    Case Access.acComboBox
                        .ColumnWidths = ScaleColumnWidths(arrCtlsScaleForm(ArrayCount).ColumnWidths, ScaleHorzFactor)
                        .ListWidth = arrCtlsScaleForm(ArrayCount).ListWidth * ScaleHorzFactor
                    Case Access.acTabCtl
                        .TabFixedWidth = arrCtlsScaleForm(ArrayCount).TabFixedWidth * ScaleHorzFactor
                        .TabFixedHeight = arrCtlsScaleForm(ArrayCount).TabFixedHeight * ScaleVertFactor
                End Select
            End With
        End If
    End If
Next


frm.Painting = True


'Keep this comments for debugging reasons
frm.txtOnOpenwindowWidth = OnOpenWindowWidth
frm.txtOnOpenwindowHeight = OnOpenWindowHeight
frm.txtCurrentwindowWidth = CurrentWindowWidth
frm.txtCurrentwindowHeight = CurrentWindowHeight
frm.txtscalevertfactor = ScaleVertFactor
frm.txtscalehorzfactor = ScaleHorzFactor


'Free up resources
Set ctl = Nothing 'Free up resources.
Set frm = Nothing 'Free up resources.


End Sub
Function isSubform(frmIn As Form) As Boolean

Dim strX As String

On Error Resume Next

strX = frmIn.Parent.NAME
isSubform = Err.Number = 0

End Function
Private Function ScaleColumnWidths(DesignColumnWidths As String, ScaleColumnWidthFactor As Single) As String

On Error Resume Next

Dim DesignColumnWidthsArray() As String
Dim NewColumnWidths As String
Dim TempVar As Long

ReDim DesignColumnWidthsArray(0)

DesignColumnWidthsArray = Split(DesignColumnWidths, ";")
NewColumnWidths = vbNullString

For TempVar = LBound(DesignColumnWidthsArray) To UBound(DesignColumnWidthsArray)
    If Not IsNull(DesignColumnWidthsArray(TempVar)) And DesignColumnWidthsArray(TempVar) <> "" Then
        NewColumnWidths = NewColumnWidths & CSng(DesignColumnWidthsArray(TempVar)) * ScaleColumnWidthFactor & ";"
    End If
Next

ScaleColumnWidths = NewColumnWidths
Erase DesignColumnWidthsArray

End Function

Function InitialInsertCodeIntoForms()

Dim loDb As Database
Dim loCont As Container
Dim loDoc As Document
Dim loForm As Form
Dim loMod As Module
Dim strName As String
Dim lngProcStartLine As Long
Dim lngProcCountLines As Long
Dim pkType As Long
Dim strCode As String


Set loDb = CurrentDb
Set loCont = loDb.Containers("Forms")


For Each loDoc In loCont.Documents
    strName = loDoc.NAME
    DoCmd.OpenForm strName, acDesign
    Set loForm = Forms(strName)
    Debug.Print loForm.NAME; ".HasModule = "; loForm.HasModule
    If loForm.HasModule = True Then
        Set loMod = loForm.Module
        On Error Resume Next
        lngProcStartLine = loMod.ProcStartLine("Form_Open", pkType)
        If Err > 0 Then
            Debug.Print vbTab; "FormOpen Added"
            loForm.OnOpen = "[Event Procedure]"
            lngProcStartLine = loMod.CountOfLines
            strCode = "Private Sub Form_Open(Cancel As Integer)" _
            & vbCrLf _
            & "ScaleFormWindow Me" _
            & vbCrLf _
            & "End Sub"
            loMod.InsertLines lngProcStartLine + 1, strCode
        Else
            Debug.Print vbTab; "FormOpen Edited"
            lngProcCountLines = loMod.ProcCountLines("Form_Open", pkType)
            loMod.InsertLines lngProcStartLine + lngProcCountLines - 1, "ScaleFormWindow Me"
        End If
        If loForm.OnOpen <> "[Event Procedure]" Then Debug.Print vbTab; "Check OnOpen Event, it is not set to [Event Procedure]."
        Err.Clear
    End If
    
    If loForm.HasModule = True Then
        Set loMod = loForm.Module
        On Error Resume Next
        lngProcStartLine = loMod.ProcStartLine("Form_Resize", pkType)
        If Err > 0 Then
            Debug.Print vbTab; "FormResize Added"
            loForm.OnOpen = "[Event Procedure]"
            lngProcStartLine = loMod.CountOfLines
            strCode = "Private Sub Form_Resize()" _
            & vbCrLf _
            & "ScaleFormControls Me" _
            & vbCrLf _
            & "End Sub"
            loMod.InsertLines lngProcStartLine + 1, strCode
        Else
            Debug.Print vbTab; "FormResize Edited"
            lngProcCountLines = loMod.ProcCountLines("Form_Resize", pkType)
            loMod.InsertLines lngProcStartLine + lngProcCountLines - 1, "ScaleFormControls Me"
        End If
        If loForm.OnResize <> "[Event Procedure]" Then Debug.Print vbTab; "Check OnResize Event, it is not set to [Event Procedure]."
        Err.Clear
    End If
    DoCmd.Close acForm, strName, acSaveYes
Next


Set loMod = Nothing
Set loForm = Nothing
Set loDoc = Nothing
Set loCont = Nothing
Set loDb = Nothing


End Function