Excel VBA | 完全商用レベルの UI デザイナー化

Excel VBA VBA
スポンサーリンク

概要

企業配布向けに再利用しやすくクラス化した UI コンポーネントセットを提供します。
各コンポーネントは「Host（UserForm 上のコンテナ）」に取り付けて使う設計です。
以下を含みます：clsCalendar（カレンダー入力）, clsProgressBar（進捗バー）, clsTableList（表表示／選択）, clsDateRangePicker（日付範囲ピッカー）, clsDropdownList（ドロップダウン付き一覧） — 各クラスのコード、API（公開メソッド／プロパティ）、使い方サンプルをステップバイステップで示します。

前準備（必須）

  1. VBA プロジェクトに下記の Class Module を追加（名前を指定した上でコードを貼る）。
    • clsCalendar、clsProgressBar、clsTableList、clsDateRangePicker、clsDropdownList
  2. 標準モジュール modUIHelper を追加（補助関数を置く）。
  3. UserForm を作成し、キャンバス用に Frame（例：fraCanvas）を置いておくとホストしやすい。
  4. 参照設定は不要（MSForms は標準）。ただし高度な操作で Scripting.Dictionary を使う場合は Microsoft Scripting Runtime を参照推奨。

全体の使い方（ステップ）

  1. UserForm 上に Frame または任意のコンテナを配置（例：fraCalendarHost）。
  2. 標準モジュールまたは UserForm のコードでクラスを New して Init にホストコントロールを渡す。
  3. クラスの公開メソッドで初期化／表示／取得を行う。
  4. 必要に応じて Host 側で WithEvents を使いイベントを受け取る。

clsProgressBar（進捗バー）

概要

UserForm の Frame / Label を利用して簡単に進捗表示。モードレスフォーム処理に便利。

クラスコード（Class Module 名：clsProgressBar）

Option Explicit

' Public API:
'   Init hostContainer As MSForms.Frame, Optional width As Single, Optional height As Single
'   SetProgress percent As Double   ' 0..1
'   SetMessage msg As String
'   Show / Hide

Private host As MSForms.Frame
Private bar As MSForms.Label
Private msgLbl As MSForms.Label
Private totalWidth As Single

Public Sub Init(hostContainer As MSForms.Frame, Optional w As Single = 200, Optional h As Single = 22)
    Set host = hostContainer
    host.Width = w
    host.Height = h + 18

    ' create bar
    Set bar = host.Controls.Add("Forms.Label.1", "pbBar", True)
    bar.Left = 2
    bar.Top = 2
    bar.Height = h
    bar.Width = 0
    bar.Caption = ""
    bar.BorderStyle = fmBorderStyleNone

    ' message label
    Set msgLbl = host.Controls.Add("Forms.Label.1", "pbMsg", True)
    msgLbl.Left = 2
    msgLbl.Top = h + 4
    msgLbl.Width = w
    msgLbl.Height = 14
    msgLbl.Caption = ""
    
    totalWidth = w - 4
End Sub

Public Sub SetProgress(percent As Double)
    If percent < 0 Then percent = 0
    If percent > 1 Then percent = 1
    bar.Width = totalWidth * percent
    DoEvents
End Sub

Public Sub SetMessage(msg As String)
    msgLbl.Caption = msg
    DoEvents
End Sub

Public Sub Show()
    host.Visible = True
    DoEvents
End Sub

Public Sub Hide()
    host.Visible = False
    DoEvents
End Sub
VB

使い方例（UserForm 側）

' UserForm に Frame: fraProgressHost を置く（幅は任意）
Private pbar As clsProgressBar

Private Sub UserForm_Initialize()
    Set pbar = New clsProgressBar
    pbar.Init Me.fraProgressHost, 300, 18
    pbar.SetMessage "準備中..."
    pbar.Show
End Sub

Sub RunWork()
    Dim i As Long
    For i = 1 To 100
        pbar.SetProgress i / 100
        pbar.SetMessage "処理中：" & i & "%"
        ' 処理...
        DoEvents
    Next
    pbar.Hide
End Sub
VB

clsCalendar（カレンダー入力）

概要

ホスト Frame に日付ボタンを描画し、日付選択時に Host に選択日を返す。ホストは WithEvents で受け取ることを想定。

クラスコード（Class Module 名：clsCalendar）

Option Explicit

' Public API:
'   Init hostContainer As MSForms.Frame, Optional baseDate As Date
'   ShowMonth dt As Date
'   SelectedDate As Date (Property)
'   OnDateSelected Event (raise on selection)

Public Event DateSelected(ByVal d As Date)

Private host As MSForms.Frame
Private displayedMonth As Date
Private selectedDateVal As Date

Public Property Get SelectedDate() As Date
    SelectedDate = selectedDateVal
End Property

Public Sub Init(hostContainer As MSForms.Frame, Optional baseDate As Date)
    Set host = hostContainer
    If baseDate = 0 Then baseDate = Date
    displayedMonth = DateSerial(Year(baseDate), Month(baseDate), 1)
    DrawCalendar
End Sub

Public Sub ShowMonth(dt As Date)
    displayedMonth = DateSerial(Year(dt), Month(dt), 1)
    DrawCalendar
End Sub

Private Sub DrawCalendar()
    Dim y As Long, x As Long, cell As MSForms.Label
    Dim firstWeekday As Long, lastDay As Long, dayIdx As Long
    host.Visible = True
    host.Controls.Clear

    ' header
    Dim hdr As MSForms.Label
    Set hdr = host.Controls.Add("Forms.Label.1", "hdr", True)
    hdr.Caption = Format(displayedMonth, "yyyy/mm")
    hdr.Left = 2: hdr.Top = 2: hdr.Width = host.Width - 4

    firstWeekday = Weekday(displayedMonth, vbSunday) ' 1..7
    lastDay = Day(DateSerial(Year(displayedMonth), Month(displayedMonth) + 1, 0))
    dayIdx = 1

    Dim r As Long, c As Long
    Dim cellLeft As Single, cellTop As Single, cellW As Single
    cellW = (host.Width - 8) / 7
    cellTop = 18

    For r = 0 To 5
        For c = 1 To 7
            Set cell = host.Controls.Add("Forms.Label.1", "d_" & r & "_" & c, True)
            cell.Left = 2 + (c - 1) * cellW
            cell.Top = cellTop + r * 20
            cell.Width = cellW - 2
            cell.Height = 18
            cell.BorderStyle = fmBorderStyleSingle
            cell.BackColor = vbWhite

            If (r * 7 + c) >= firstWeekday And dayIdx <= lastDay Then
                cell.Caption = CStr(dayIdx)
                cell.Tag = CStr(dayIdx)
                dayIdx = dayIdx + 1
            Else
                cell.Caption = ""
            End If
        Next
    Next

    ' attach click handlers via host's event model is not trivial in class; instead we use host to trap Click via naming convention
End Sub

' Host UserForm should call this when a label is clicked:
Public Sub HandleLabelClick(lblName As String)
    Dim ctrl As MSForms.Control
    On Error Resume Next
    Set ctrl = host.Controls(lblName)
    On Error GoTo 0
    If Not ctrl Is Nothing Then
        If ctrl.Tag <> "" Then
            selectedDateVal = DateSerial(Year(displayedMonth), Month(displayedMonth), CLng(ctrl.Tag))
            RaiseEvent DateSelected(selectedDateVal)
        End If
    End If
End Sub
VB

Host（UserForm）での利用例

Private cal As clsCalendar

Private Sub UserForm_Initialize()
    Set cal = New clsCalendar
    cal.Init Me.fraCalendarHost, Date
    ' 注意: カレンダー内のラベルがクリックされたら以下を呼ぶ仕組みを作る必要あり
End Sub

' 以下を UserForm の Click イベントで切り分ける簡易例（実務では個別ラベルの Click を割り当てる）
Private Sub fraCalendarHost_Click()
    ' クリックされたコントロール名を取得する方法は簡易では難しいため、
    ' 各ラベルに直接 Click イベントを作るか、ラベルを生成した時に名前を Host に記録しておく方法を採る
End Sub

' あるラベルの Click イベントから：
Private Sub d_0_1_Click()
    cal.HandleLabelClick "d_0_1"
End Sub

' クラスのイベント受信
Private Sub cal_DateSelected(ByVal d As Date)
    MsgBox "選択日: " & Format(d, "yyyy/mm/dd")
End Sub
VB

実装ノート：UserForm 上で動的に生成したラベルの個別 Click を扱うためには、WithEvents を使うラッパークラスを別途作り、生成時に各ラベルにラッパーを割り当てる手法が望ましい（前の設計文の clsDraggable と同様）。

clsTableList（表表示／選択）

概要

シート範囲または二次元配列を ListBox に流し込み、選択行の取得・ソート・列表示（ColumnCount）を提供。

クラスコード（Class Module 名：clsTableList）

Option Explicit

' Public API:
'   Init hostList As MSForms.ListBox, Optional colCount As Long = 1
'   LoadFromRange rng As Range
'   LoadFromArray arr
'   GetSelectedRowIndex() As Long
'   GetSelectedRow() As Variant

Private lst As MSForms.ListBox
Private colCnt As Long

Public Sub Init(hostList As MSForms.ListBox, Optional columns As Long = 1)
    Set lst = hostList
    colCnt = columns
    lst.Clear
    lst.ColumnCount = colCnt
End Sub

Public Sub LoadFromRange(rng As Range)
    Dim data
    If rng.Rows.Count = 0 Then Exit Sub
    data = rng.Value
    lst.List = data
    lst.ColumnCount = rng.Columns.Count
End Sub

Public Sub LoadFromArray(arr As Variant)
    lst.List = arr
End Sub

Public Function GetSelectedRowIndex() As Long
    GetSelectedRowIndex = lst.ListIndex
End Function

Public Function GetSelectedRow() As Variant
    If lst.ListIndex = -1 Then
        GetSelectedRow = Empty
    Else
        Dim i As Long, tmp()
        ReDim tmp(1 To lst.ColumnCount)
        For i = 0 To lst.ColumnCount - 1
            tmp(i + 1) = lst.List(lst.ListIndex, i)
        Next
        GetSelectedRow = tmp
    End If
End Function
VB

使い方例（UserForm）

' UserForm 上に ListBox: lstTable を配置
Private t As clsTableList

Private Sub UserForm_Initialize()
    Set t = New clsTableList
    t.Init Me.lstTable, 3
    t.LoadFromRange Sheet1.Range("A1:C20")
End Sub

Private Sub cmdSelect_Click()
    Dim idx As Long
    idx = t.GetSelectedRowIndex()
    If idx = -1 Then MsgBox "未選択": Exit Sub
    Dim row As Variant
    row = t.GetSelectedRow()
    MsgBox "選択: " & row(1) & " | " & row(2) & " | " & row(3)
End Sub
VB

clsDateRangePicker（日付範囲ピッカー）

概要

clsCalendar を2つ使って From/To を選択し、日付の整合チェックを行う小型 API。

クラスコード（Class Module 名：clsDateRangePicker）

Option Explicit

' Public API:
'   Init hostFrom As MSForms.Frame, hostTo As MSForms.Frame
'   Show / Hide
'   GetRange -> (DateFrom As Date, DateTo As Date)
'   Event RangeSelected(DateFrom, DateTo)

Public Event RangeSelected(ByVal d1 As Date, ByVal d2 As Date)

Private calFrom As clsCalendar
Private calTo As clsCalendar
Private dateFrom As Date, dateTo As Date

Public Sub Init(hostFrom As MSForms.Frame, hostTo As MSForms.Frame)
    Set calFrom = New clsCalendar
    calFrom.Init hostFrom, Date
    Set calTo = New clsCalendar
    calTo.Init hostTo, Date

    ' 別途、各 cal の DateSelected を受け取る仕組みが必要
End Sub

Public Sub HandleFromSelected(ByVal d As Date)
    dateFrom = d
    If dateTo <> 0 Then ValidateAndRaise
End Sub

Public Sub HandleToSelected(ByVal d As Date)
    dateTo = d
    If dateFrom <> 0 Then ValidateAndRaise
End Sub

Private Sub ValidateAndRaise()
    If dateFrom > dateTo Then
        MsgBox "開始日が終了日より後です。"
        Exit Sub
    End If
    RaiseEvent RangeSelected(dateFrom, dateTo)
End Sub

Public Function GetRange() As Variant
    Dim out(1 To 2) As Date
    out(1) = dateFrom
    out(2) = dateTo
    GetRange = out
End Function
VB

使い方（UserForm）

' UserForm に fraFromHost, fraToHost を配置
Private drp As clsDateRangePicker

Private Sub UserForm_Initialize()
    Set drp = New clsDateRangePicker
    drp.Init Me.fraFromHost, Me.fraToHost
End Sub

' それぞれの calendar ラベル Click から：
Private Sub dFrom_0_1_Click()
    drp.HandleFromSelected DateSerial(Year(Date), Month(Date), 1) ' 実際は HandleLabelClick を経由
End Sub

Private Sub drp_RangeSelected(ByVal d1 As Date, ByVal d2 As Date)
    MsgBox "範囲: " & Format(d1, "yyyy/mm/dd") & " - " & Format(d2, "yyyy/mm/dd")
End Sub
VB

clsDropdownList（ドロップダウンつき一覧）

概要

コンボボックスで絞り込み、ListBox に結果を表示する小型コンポーネント。

クラスコード（Class Module 名：clsDropdownList）

Option Explicit

' Public API:
'   Init cmb As MSForms.ComboBox, lst As MSForms.ListBox, srcRange As Range
'   RefreshList
'   GetSelected As Variant

Private cmbBox As MSForms.ComboBox
Private lstBox As MSForms.ListBox
Private src As Range

Public Sub Init(cmb As MSForms.ComboBox, lst As MSForms.ListBox, srcRange As Range)
    Set cmbBox = cmb
    Set lstBox = lst
    Set src = srcRange

    ' populate combo with distinct values from 2nd column (example)
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim r As Range
    For Each r In src.Rows
        dict(r.Cells(1, 2).Value) = 1
    Next
    cmbBox.Clear
    cmbBox.AddItem ""
    Dim k
    For Each k In dict.Keys
        cmbBox.AddItem k
    Next
    RefreshList
End Sub

Public Sub RefreshList()
    Dim key As String: key = cmbBox.Value
    Dim buf(), cnt As Long
    Dim r As Range, matchCount As Long
    matchCount = 0
    For Each r In src.Rows
        If key = "" Or r.Cells(1, 2).Value = key Then
            matchCount = matchCount + 1
            ReDim Preserve buf(1 To matchCount, 1 To src.Columns.Count)
            Dim c As Long
            For c = 1 To src.Columns.Count
                buf(matchCount, c) = r.Cells(1, c).Value
            Next
        End If
    Next
    If matchCount > 0 Then
        lstBox.List = buf
    Else
        lstBox.Clear
    End If
End Sub

Public Function GetSelected() As Variant
    If lstBox.ListIndex = -1 Then
        GetSelected = Empty
    Else
        Dim out()
        ReDim out(1 To lstBox.ColumnCount)
        Dim i As Long
        For i = 0 To lstBox.ColumnCount - 1
            out(i + 1) = lstBox.List(lstBox.ListIndex, i)
        Next
        GetSelected = out
    End If
End Function
VB

使い方（UserForm）

' Place ComboBox: cmbFilter, ListBox: lstFiltered
Private dd As clsDropdownList

Private Sub UserForm_Initialize()
    Set dd = New clsDropdownList
    dd.Init Me.cmbFilter, Me.lstFiltered, Sheet1.Range("A1:C100")
End Sub

Private Sub cmbFilter_Change()
    dd.RefreshList
End Sub
VB

配布用パッケージ化の注意（短く）

  • 各クラスは ホスト側のコントロール命名規則（例：ラベル名 d_r_c）に依存する部分があるため、ドキュメント（命名規則）を同梱してください。
  • カレンダー等のクリックイベントは動的生成ラベルの Click を捕捉する仕組み（ラッパークラス + WithEvents）を推奨します。サンプルにそのラッパー実装を追加すると即戦力になります。
  • Scripting.Dictionary を使う場合は Microsoft Scripting Runtime を参照するか、CreateObject を使って参照不要にしてください（上のサンプルでは後者を使っています）。
前へ
12
スポンサーリンク
タイトルとURLをコピーしました