【VBA】ユーザーフォームのサイズを変更しつつコントロールを自動リサイズする方法

ユーザーフォームの大きさを変更しつつ、コントロールのサイズをユーザフォームに合わせてリサイズする方法を説明していきます。

コード

モジュール側のコード

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

Option Explicit

''' <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

サンプルコード

拡大を押すと現在のサイズから二倍に拡大され、縮小を押すと現在のサイズから0.5倍に縮小されるサンプルです。

ユーザーフォームに「ZoomButton」と「ZoomOutButton」を作成後、以下のコードを張り付けてください。

Option Explicit

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

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

''' <summary>
''' フォームサイズを2倍に拡大する
''' </summary>
''' <remarks></remarks>
Private Sub ZoomButton_Click()
    Call FormSizeChange(Me, meFormInfo, Me.Width * 2, Me.Height * 2)
End Sub

''' <summary>
''' フォームサイズを0.5倍に縮小する
''' </summary>
''' <remarks></remarks>
Private Sub ZoomOutButton_Click()
    Call FormSizeChange(Me, meFormInfo, Me.Width * 0.5, Me.Height * 0.5)
End Sub