t-hom’s diary

主にVBAネタを扱っているブログ…とも言えなくなってきたこの頃。

Excel VBAでスクロール可能なフォームのアイデア

VBA ユーザーフォーム クラスモジュール活用

Excel VBAでフォームを作る際に、項目が多くてウインドウの高さに収まりきらないことがある。
そこで今回はスクロールによってフォーム全体をウインドウに収めるアイデアを紹介する。

言葉では何がやりたいのか伝わりにくいと思うのでまずは動作イメージから。

動作イメージ

f:id:t-hom:20190505103218g:plain

注意事項

あくまでアイデアなので、実用化にはまだ色々と工夫が必要になる。
今のままではデータの取り出しすらままならないのだが、本記事のコードを読める人なら自分で実装できると思われる。

コード

クラスモジュール「FieldLocator」

まずはクラスモジュールを挿入し、オブジェクト名をFieldLocatorとする。
このFieldLocatorはデータフィールド用のテキストボックスとそのラベルを生成し、座標を管理するオブジェクトだ。
最初のFieldLocatorから次のFieldLocatorへ、そこからまた次のFieldLocatorへと参照が張られ、とリスト構造(数珠状)でつながる仕組み。
1カラムのテキストボックス、2カラムのテキストボックスのみ対応している。

コードはこちら。

'DEBUG_MODEはラベルを配置するときに色が付いてないとサイズが分かりづらいので作った。
'Falseにすると色付け無しになる。
#Const DEBUG_MODE = False
Private top_ As Long
Public Left As Long
Public FieldName1 As String
Public FieldName2 As String
Public LabelWidth As Integer
Public LineCount As Integer
Public L1 As MSForms.Label, L2 As MSForms.Label
Public T1 As MSForms.TextBox, T2 As MSForms.TextBox

'すべてのFieldLocatorは最初のアイテムからNextItemを辿って数珠状につながる想定。
'これにより、最初のアイテムのTopプロパティーを変更すると、連鎖的に他のアイテムのTopプロパティーも変わる。
'つまり全てのコントロールが最初のアイテムに連動して動くので、スクロールバーで動かすのは最初のアイテムだけでOKになる。
Public NextItem As FieldLocator

Const FONT_SIZE = 12, FONT_HEIGHT = 15, FONT_MARGIN = 6

Private Sub Class_Initialize()
    Me.LineCount = 1
    Me.LabelWidth = 100
End Sub
Public Property Get Self() As FieldLocator
    Set Self = Me
End Property

Public Function CreateNext() As FieldLocator
    With New FieldLocator
        .Top = Me.Bottom + 10
        .Left = Me.Left
        .LabelWidth = Me.LabelWidth
        Set NextItem = .Self
        Set CreateNext = NextItem
    End With
End Function

Public Property Let Top(t_ As Long)
    top_ = t_
    If Not T1 Is Nothing Then
        CCnt(T1).Top = t_
        CCnt(L1).Top = CCnt(T1).Top + 2
        If Not T2 Is Nothing Then
            CCnt(T2).Top = CCnt(T1).Top
            CCnt(L2).Top = CCnt(L1).Top
        End If
    End If
    If Not NextItem Is Nothing Then
        NextItem.Top = Me.Bottom + 10
    End If
End Property
Public Property Get Top() As Long
    If T1 Is Nothing Then
        Top = top_
    Else
        Top = CCnt(T1).Top
    End If
End Property
Public Property Get Bottom() As Long
    Bottom = CCnt(T1).Top + CCnt(T1).Height
End Property

Sub AddInputBox(f As UserForm)
    Set L1 = f.Controls.Add("Forms.Label.1")
    L1.Font.Name = "Meiryo UI"
    L1.Font.Size = FONT_SIZE
    CCnt(L1).Height = FONT_HEIGHT + FONT_MARGIN
    CCnt(L1).Width = LabelWidth
    CCnt(L1).Left = Left
    L1.TextAlign = fmTextAlignRight
    L1.Caption = FieldName1
#If DEBUG_MODE Then
    L1.BackColor = rgbLightYellow
#End If
    
    Set T1 = f.Controls.Add("Forms.Textbox.1")
    T1.BorderStyle = fmBorderStyleSingle
    T1.Font.Name = "Meiryo UI"
    T1.Font.Size = FONT_SIZE
    T1.MultiLine = LineCount > 1
    T1.ScrollBars = fmScrollBarsVertical
    T1.EnterKeyBehavior = LineCount > 1
    CCnt(T1).Height = FONT_HEIGHT * LineCount + FONT_MARGIN
    CCnt(T1).Width = 450
    CCnt(T1).Left = CCnt(L1).Left + CCnt(L1).Width + 10
    CCnt(T1).Top = top_
    
    CCnt(L1).Top = CCnt(T1).Top + 2
End Sub

Sub AddTwinInputBox(f As UserForm)
    Set L1 = f.Controls.Add("Forms.Label.1")
    L1.Font.Name = "Meiryo UI"
    L1.Font.Size = FONT_SIZE
    CCnt(L1).Height = FONT_HEIGHT + FONT_MARGIN
    CCnt(L1).Width = LabelWidth
    CCnt(L1).Left = Left
    L1.TextAlign = fmTextAlignRight
    L1.Caption = FieldName1
#If DEBUG_MODE Then
    L1.BackColor = rgbLightYellow
#End If

    Set L2 = f.Controls.Add("Forms.Label.1")
    L2.Font.Name = "Meiryo UI"
    L2.Font.Size = FONT_SIZE
    CCnt(L2).Height = FONT_HEIGHT + FONT_MARGIN
    CCnt(L2).Width = LabelWidth
    L2.TextAlign = fmTextAlignRight
    L2.Caption = FieldName2
#If DEBUG_MODE Then
    L2.BackColor = rgbLightYellow
#End If
    
    Set T1 = f.Controls.Add("Forms.Textbox.1")
    T1.BorderStyle = fmBorderStyleSingle
    T1.Font.Name = "Meiryo UI"
    T1.Font.Size = FONT_SIZE
    T1.MultiLine = LineCount > 1
    T1.ScrollBars = fmScrollBarsVertical
    T1.EnterKeyBehavior = LineCount > 1
    CCnt(T1).Height = FONT_HEIGHT * LineCount + FONT_MARGIN
    CCnt(T1).Width = (450 - 20 - LabelWidth) / 2
    CCnt(T1).Left = CCnt(L1).Left + CCnt(L1).Width + 10
    CCnt(T1).Top = top_
    
    CCnt(L1).Top = CCnt(T1).Top + 2
    CCnt(L2).Left = CCnt(T1).Left + CCnt(T1).Width + 10
    CCnt(L2).Top = CCnt(L1).Top
    
    Set T2 = f.Controls.Add("Forms.Textbox.1")
    T2.BorderStyle = fmBorderStyleSingle
    T2.Font.Name = "Meiryo UI"
    T2.Font.Size = FONT_SIZE
    T2.MultiLine = LineCount > 1
    T2.ScrollBars = fmScrollBarsVertical
    T2.EnterKeyBehavior = LineCount > 1
    CCnt(T2).Height = FONT_HEIGHT * LineCount + FONT_MARGIN
    CCnt(T2).Width = CCnt(T1).Width
    CCnt(T2).Left = CCnt(L2).Left + CCnt(L2).Width + 10
    CCnt(T2).Top = top_
End Sub

Private Function CCnt(o As Object) As MSForms.Control
    Set CCnt = o
End Function

フォームモジュール

ユーザーフォームを挿入し、次のコードを張り付ける。
フォームのオブジェクト名は任意で良い。

Dim FirstField As FieldLocator
Private WithEvents ScrollBar1 As MSForms.ScrollBar
Private Sub ScrollBar1_Change()
    'ScrollBarはマイナス値をMaxに設定すると、増分がマイナスになるので、
    '次のようにシンプルに書ける。
    FirstField.Top = ScrollBar1.Value
End Sub

Private Sub UserForm_Initialize()
    Set ScrollBar1 = Me.Controls.Add("Forms.ScrollBar.1")
    Const GOLDEN_RATIO = 1.618
    Me.Width = 800 '所有してるモニタの最低解像度の横幅が800(SVGA)なので。ちなみに最高は1920。
    Me.Height = Me.Width / GOLDEN_RATIO '黄金比を用いて収まりよく。
    ScrollBar1.Width = 20
    ScrollBar1.Left = Me.Width - 25
    ScrollBar1.Height = Me.Height - 22
    ScrollBar1.SmallChange = 5
    ScrollBar1.LargeChange = 20
    With New FieldLocator
        '最初の作成で設定する
        Set FirstField = .Self
        .Top = 30
        ScrollBar1.Min = .Top
        .Left = 100
        .LabelWidth = 80
        
        '以降の設定項目は共通
        .FieldName1 = "件名"
        .LineCount = 1 'LineCountは省略すると1になる。
        .AddInputBox Me 'これは1カラムの入力フィールドを追加するコマンド
        
    '以降はCreateNextのメソッドチェーンでFieldLocatorを数珠状に作っていく。
    With .CreateNext
        .FieldName1 = "概要"
        .LineCount = 2
        .AddInputBox Me
    With .CreateNext
        .FieldName1 = "詳細"
        .LineCount = 10
        .AddInputBox Me
    With .CreateNext
        '2カラムの入力フィールドの場合はこうする。
        .FieldName1 = "開始日"
        .FieldName2 = "有効期限"
        .AddTwinInputBox Me
    With .CreateNext
        .FieldName1 = "担当者"
        .AddInputBox Me
    With .CreateNext
        .FieldName1 = "連絡先"
        .AddInputBox Me
    With .CreateNext
        .FieldName1 = "備考欄"
        .LineCount = 10
        .AddInputBox Me
    With .CreateNext
        .FieldName1 = "その他"
        .AddInputBox Me
        
        '最後の要素のBottomを利用してScrollBarのMax値
        '(プロパティ名はMaxだが、実際にはマイナス値なので最小)を決定する。
        ScrollBar1.Max = Me.Height - .Bottom - 30
    
    'メソッドチェーンが終わると、残念ながら大量のEnd With文
    End With: End With: End With: End With: End With: End With: End With: End With
End Sub

フォーム自体を除き、パーツはすべてコードで生成する為、フォーム上には何も配置しなくて良い。
サイズもコードで指定するのでそのままで良い。
フォームを起動すると冒頭の動作イメージのとおり操作できる。

あとがき

Access Formを使えばこんなことは朝飯前なんだけど、Excelにちょっとしたフォームが欲しくなることもある。
標準のフォーム機能ってのもあった気がするけど、使い勝手がとても悪いので、自作を試みているところ。

ちょっとしたフォームにしては作り方が大掛かりに見えるかもしれないが、使いまわしができ、デザインの微調整が必要なく、単に項目を指定していくだけで完成する汎用的なフォーム作成が目的なので、この手間は仕方がない。

おまけ

以下はスクロールバーをMin 0% Max 100%のパーセンテージで管理しようともがいてる図。
f:id:t-hom:20190505105800p:plain
結局、Maxをマイナス値にするとマイナスに向かって進むことが判明し、コードをよりシンプルに出来るのでパーセンテージ管理は没になった。


以下はHeight Managerというオブジェクトでラベルとテキストボックスを管理し、双方向ポインタで結ぶことで先頭を動かすと全体が動く仕組みを作ろうとした図。
f:id:t-hom:20190505105828p:plain
このアイデアは別の形(FieldLocator)で実現した。実際には片方向ポインタで十分だった。
上下のボーダーを跨ぐとコントロールを非表示にするアイデアだったが実装に至っていない。

現在はスクロールによってフォームの上端・下端でコントロールが見えなくなるが、本当はZOrderをトップにしたラベルの下に潜り込ませて、完全に潜ったらHiddenにしようと考えている。ちょっと管理すべき項目が多くて混乱中。

当ブログは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。