【VBA】ユーザー側の操作でユーザーフォームをリサイズした際にコントロールも自動的にリサイズする方法

ユーザー側の操作でユーザーフォームとリサイズした際に、コントロールも自動的にリサイズする方法を説明していきます。

コード

以下のコードを指定の場所に張り付けてください。

モジュール側のコード

適当なモジュールに以下のコードを貼り付けてください。

Option Explicit

'フォームリサイズに使用するWindows API宣言(64bit/32bit両対応)
Private Const GWL_STYLE = (-16)
Private Const WS_THICKFRAME = &H40000
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long

''' <summary>
''' ' フォームをリサイズ可能な状態に変更
''' </summary>
''' <remarks></remarks>
Public Sub FormRisizeSetting()
    Dim result As Long
    Dim hwnd As Long
    Dim Wnd_STYLE As Long

    hwnd = GetActiveWindow()
    Wnd_STYLE = GetWindowLong(hwnd, GWL_STYLE)
    Wnd_STYLE = Wnd_STYLE Or WS_THICKFRAME Or &H30000

    result = SetWindowLong(hwnd, GWL_STYLE, Wnd_STYLE)
    result = DrawMenuBar(hwnd)
End Sub

''' <summary>
'''フォームサイズとコントロールサイズを記録する
''' </summary>
''' <param name="formObj">フォームのオブジェクト</param>
''' <returns>フォームのコントロール一覧</returns>
''' <remarks></remarks>
 Function FormSizeRec(ByRef formObj As Object) As Collection
    '初期化
     Dim rtn As New Collection
     Set FormSizeRec = rtn
    'フォームのサイズを記録
    With formObj
        rtn.Add New Collection, .Name
        rtn(.Name).Add .Width, "Width"
        rtn(.Name).Add .Height, "Height"
    End With
    'フォーム内の全コントロールのサイズと位置を記録
    Dim con As Variant
    For Each con In formObj.Controls
        With con
            rtn.Add New Collection, .Name
            rtn(.Name).Add .Width, "Width"
            rtn(.Name).Add .Height, "Height"
            rtn(.Name).Add .Top, "Top"
            rtn(.Name).Add .Left, "Left"
            '対象プロパティが存在しない場合は無視
            On Error Resume Next
            rtn(.Name).Add .Font.Size, "FontSize"
            On Error GoTo 0
        End With
    Next
End Function

''' <summary>
''' 指定サイズに合わせフォームとコントロールを伸縮する。
''' </summary>
''' <param name="formObj">フォームのオブジェクト</param>
''' <param name="formInfo">フォームのコントロール一覧</param>
''' <param name="formWidth">フォームの幅</param>
''' <param name="formHeight"フォームの高さ></param>
''' <remarks></remarks>
Sub FormSizeChange(ByRef formObj As Object, ByRef formInfo As Collection, ByVal formWidth As Long, ByVal formHeight As Long)
  'フォームのサイズを変更
  Dim widthRate As Double
  Dim heightRate As Double
  With formObj
        '最大化中はフォームサイズを変更しない
        On Error Resume Next
        widthRate = formWidth / formInfo(.Name)("Width")
        heightRate = formHeight / formInfo(.Name)("Height")
         .Width = formInfo(.Name)("Width") * widthRate
         .Height = formInfo(.Name)("Height") * heightRate
         On Error GoTo 0
    End With
    'フォーム内の全コントロールのサイズと位置を変更
    Dim con As Variant
    For Each con In formObj.Controls
        With con
            .Width = formInfo(.Name)("Width") * widthRate
            .Height = formInfo(.Name)("Height") * heightRate
            .Top = formInfo(.Name)("Top") * heightRate
            .Left = formInfo(.Name)("Left") * widthRate
             '対象プロパティが存在しない場合は無視
             On Error Resume Next
             If widthRate > heightRate Then
                .Font.Size = formInfo(.Name)("FontSize") * heightRate
            Else
                .Font.Size = formInfo(.Name)("FontSize") * widthRate
            End If
             On Error GoTo 0
        End With
    Next
    'フォームの再描画
    DoEvents
    formObj.Repaint
    DoEvents
End Sub

ユーザーフォーム側のコード

以下のコードをユーザーフォームに張り付けてください。

Option Explicit

Dim meFormInfo As Collection  'フォームとコントロールのサイズ記録用

''' <summary>
''' フォームとコントロールの初期サイズを記録
''' </summary>
''' <remarks></remarks>
Private Sub UserForm_Initialize()
     Set meFormInfo = FormSizeRec(Me)
End Sub

''' <summary>
''' 'フォームをリサイズ可能な状態にする
''' </summary>
''' <remarks></remarks>
Private Sub UserForm_Activate()
    Call FormRisizeSetting
End Sub

''' <summary>
'''フォームリサイズ時にコントロールの配置を自動変更
''' </summary>
''' <remarks></remarks>
Private Sub UserForm_Resize()
    Call FormSizeChange(Me, meFormInfo, Me.Width, Me.Height)
End Sub