Access VBA フォームサイズ変更関数

gistfile1.vb

Option Compare Database
Option Explicit


' ***************************************
' 関数名： FormSizeChange
' 目　的： フォームのサイズ、各コントロールのサイズ/位置を指定した比率で
'          拡大/縮小します。
' 作成者： hatena
' 引数：
' Frm -> 対象フォームオブジェクト
' R  -> 拡大/縮小の比率
'エラーがでた場合は、Falseを返す
' 使用例：
' フォームの開くときのイベントでフォームのサイズを指定したサイズに。
' FormSizeChange(Me, 1.2)
' ***************************************
Public Function FormSizeChange(Frm As Form, R As Double) As Boolean
Const Retry = 3 'リトライ回数

Dim i As Long, j As Long
Dim FrmW As Long '変更後のフォームの幅
Dim SecH(4) As Long '変更後の各セクションの高さ
Dim Ctls() As Variant '変更後のコントロールの位置とサイズの格納用
Dim complete As Boolean 'サイズ変更完了フラグ
Dim ErrMsg As String

On Error GoTo Err_FormSizeChange

    If R = 1 Or R < 0 Then Exit Function
   
    Frm.Painting = False
    
    'フォーム幅、セクション高さの上限値を越える場合は拡大率を調整
    If R > 1 Then
        If Frm.Width * R > 22 * 1440 Then
            R = 22 * 1440 / Frm.Width
        End If
        For i = 0 To 4
            If Frm.Section(i).Height * R > 22 * 1440 Then
                R = 22 * 1440 / Frm.Section(i).Height
            End If
        Next
    End If
    
    FrmW = Frm.Width * R
    If R > 1 Then Frm.Width = FrmW
    
    For i = 0 To 4
        SecH(i) = Frm.Section(i).Height * R
        If R > 1 Then Frm.Section(i).Height = SecH(i)
    Next
    
    ReDim Ctls(Frm.Count - 1)
       
    For i = 0 To UBound(Ctls)
    With Frm.Controls(i)
       If .ControlType = acPageBreak Then
           Ctls(i) = Array(0, Int(.Top * R), 0, 0)
       Else
           Ctls(i) = Array(Int(.Left * R), Int(.Top * R), Int(.Width * R), Int(.Height * R))
       End If
    End With
    Next
    
    For i = UBound(Ctls) To 0 Step -1
    With Frm.Controls(i)
        If .ControlType <> acPage Then
            .FontSize = getFontSize(.FontSize * R)
            .Left = Ctls(i)(0)
            .Top = Ctls(i)(1)
            .Width = Ctls(i)(2)
            .Height = Ctls(i)(3)
        End If
    End With
    Next

    For j = 0 To Retry
        complete = True
        For i = UBound(Ctls) To 0 Step -1
            With Frm.Controls(i)
            If .ControlType <> acPage Then
            If Not (.Left = Ctls(i)(0) And .Top = Ctls(i)(1) And .Width = Ctls(i)(2) And .Height = Ctls(i)(3)) Then
                .Left = Ctls(i)(0)
                .Top = Ctls(i)(1)
                .Width = Ctls(i)(2)
                .Height = Ctls(i)(3)
                complete = False
            End If
            End If
            End With
        Next
        If complete Then
            Exit For
        End If
    Next
    
    Frm.Width = FrmW
   
    For i = 0 To 4
        Frm.Section(i).Height = SecH(i)
    Next

        
    FormSizeChange = Len(ErrMsg) = 0
    If Not FormSizeChange Then MsgBox ErrMsg
    
    Frm.Painting = True
    Exit Function
    
Err_FormSizeChange:
    Select Case Err.Number
    Case 438, 2100, 2462
        '438: オブジェクトは、このプロパティまたはメソッドをサポートしていません。
        '2100: コントロールまたはサブフォーム コントロールが大きすぎるため、配置できません。
        '2462: セクション番号の指定が正しくありません｡
        '上記のエラーは無視
    Case Else
        ErrMsg = ErrMsg & Err.Number & ": " & Err.Description & vbCrLf
    End Select
    Resume Next
    
End Function

Private Function getFontSize(FontSize As Long) As Long
    Select Case FontSize
    Case Is < 1 'フォントサイズの下限値
        getFontSize = 1
    Case Is > 127  'フォントサイズの上限値
        getFontSize = 127
    Case Else
        getFontSize = FontSize
    End Select
End Function

Excel VBA を学ぶなら moug モーグ｜Access （VBA）｜全てのコントロールのサイズを大きくするとオプショングループが変になる

子コントロールの移動、サイズ変更で親の位置/サイズが変更されるので、Controls順でやってもうまくいかない。
影響がないようなロジックを考えると複雑になりすぎる。

ということで、目標のサイズになるまで、リサイズを何回かくり返すようにした。

孫コントロール→子コントロール→親コントロール の順で変更した方がリトライが少なくてすむ。
Controls順は、親→子→孫 の順に並んでいるらしい。
Controlsの逆順で変更するようにした。

更新履歴
2012/02/08
・改ページコントロールの位置変更がされていなかったのを修正
・フォーム幅、セクション高の上限値を超える場合に調整するコードを追加
・エラー処理を少しまともなものに変更
2012.02.06
・フォントサイズの下限値と上限値を考慮したコードを追加。