【Access VBA】１ヶ月分のレコードを日付ごとの一覧表示にする

前回は個人ごとの予約一覧をPDFに出力する仕組みを実装しました。

全体の予約状況を確認を確認するために、１ヶ月分の全レコードを日付ごとの一覧表示にしたいところ。

いろいろ調べていたところ下記のリンクが参考になりました。

カレンダー形式でスケジュールを表示できる設計例です。最終的には、スケジュールデータの詳細表示、入力もできるように設計します。祝祭日表示にも対応する予定です。今回は、チュートリアル形式で、一から制作手順を紹介します。効率的な開発法の御参考に...

なるほど、取得したデータを元にラベルのキャプションを変えることで一覧に表示するというわけですね。

完成サンプル
作成手順

完成サンプル

登録用フォームに「月間一覧」というボタンを用意します。「tx表示年」と「cmb表示月」で選んだ年月の一覧を表示します。

１ヶ月分の日付の行と、10件までの予約について氏名と時間が表示されます。

フォームヘッダーには前月・次月への移動ボタンと、動的に内容が変わるわけではないので更新ボタンを設置しています。

作成手順

クエリの準備

月間一覧のフォームに、IDで記録している氏名と時間を渡したいので、クエリを準備します。VBA内でこのクエリから値を取得するようにします。

フォームの準備

参考サイトに書かれている内容をベースにフォームを準備します。

フォーム内にラベルを準備します。縦に31行（日数分）、横に11列（日付の列を含めて表示したい件数）になるようにします。

最初に配置したラベルの名前が「ラベル0」、最後が「ラベル340」になるようにします。途中で配置したラベルを削除したりするとこの後のマクロがうまくいかなくなるので注意です。

それでは作ったラベルの名前とキャプションを一括変換するマクロを実行します。下記VBAを標準モジュールに記述して実行します。

Public Sub LabelRename()
    Dim i As Long
    Dim n As Long
    Dim r As Long
    Dim c As Long
    
    With Forms!F_予約月間一覧
        For i = 0 To 30
            .Controls("ラベル" & i).Caption = "D" & i + 1
            .Controls("ラベル" & i).Name = "D" & i + 1
        Next
        
        For r = 1 To 31
            For c = 1 To 10
                n = 30 * c + c + r - 1
                .Controls("ラベル" & n).Caption = "T" & r & "_" & c
                .Controls("ラベル" & n).Name = "T" & r & "_" & c
            Next c
        Next r
    End With

End Sub

こうなります。D1～D31は日付を表示、T1_1～T1_10に１日に予約のある10件分のデータを表示、それがT31まであるという感じです。

そしてこれらのラベルのサイズと配置の調整を一斉に行うマクロを同じく標準モジュール内に記述して実行します。

Public Function LabelSetSize()
    Const CalLeft = 0.2 * 567  'カレンダー 左位置 0.2cm
    Const CalTop = 0.2 * 567     'カレンダー 上位置 1cm
    Const ColWidth = 3 * 567   '列幅　2cm
    Const DHeight = 0.8 * 567 '列幅　0.55cm
    Const THeight = 0.8 * 567  '列幅　1.5cm
    Dim i As Long
    Dim Row As Integer, Col As Integer
     
    With Forms!F_予約月間一覧
        For i = 1 To 31
            Row = i - 1
            .Controls("D" & i).Move _
            0 * ColWidth + CalLeft, _
            Row * (DHeight) + CalTop, _
            ColWidth, DHeight
            For j = 1 To 10
                Col = j
                
                .Controls("T" & i & "_" & j).Move _
                    Col * ColWidth + CalLeft, _
                    Row * (THeight) + CalTop, _
                    ColWidth, THeight
            Next j
        Next i
    End With
 End Function

こんな感じになりました。一つのラベル内に氏名と時間の２行分表示するために幅と高さを調整しています。

あとは日付を太字にして、フォームヘッダーにtx表示年、tx表示月、btnPrev、btnNext、btn更新を配置します。

VBA

「btn月間一覧」押下時

Private Sub btn月間一覧_Click()
    DoCmd.OpenForm "F_予約月間一覧"
End Sub

フォーム「F_月間一覧」読込時

Private Sub Form_Load()
    Me.btnPrev.OnClick = "=MoveMonth(-1)"
    Me.btnNext.OnClick = "=MoveMonth(1)"
    Me.tx表示年 = Forms!F_予約フォーム.tx表示年
    Me.tx表示月 = Forms!F_予約フォーム.cmb表示月
    SetCalendar
End Sub

フォームの読込時にbtnPrevとbtnNextで実行する関数の設定、tx表示年とtx表示月の値セット、次項で定義するSetCalendarの呼び出しを行います。

日にち設定を行うSetCalendar

Private Function SetCalendar()
    Dim i As Integer, j As Integer, D As Date, m As Integer, n As Integer
    Dim term As Integer
    Dim dayBuf As Variant

    term = 30
    m = Me.tx表示月
    FirstDay = DateSerial(Me.tx表示年, m, 1)
    For i = 1 To 31
        With Me("D" & i)
            D = FirstDay + i - 1
'            .Caption = Day(D)
            If Weekday(D) = 1 Then
                .ForeColor = vbRed      '日曜は赤文字
            ElseIf Weekday(D) = 7 Then
                .ForeColor = vbBlue     '土曜は青文字
            Else
                .ForeColor = vbBlack
            End If
            n = Month(D)
            If m = n Then
                .Caption = Format(D, "yyyy/mm/dd(aaa)")
                .FontSize = 11
            Else
                .Caption = ""
                If term = 30 Then
                    term = i - 2
                End If
            End If
        End With
        
        For j = 1 To 10
            Me("T" & i & "_" & j).Caption = ""
        Next j
    Next i
    
    Dim rs As DAO.Recordset
    Set rs = CurrentDb.OpenRecordset( _
        "SELECT 日付,開始時間,終了時間,氏名 FROM Q_予約台帳_選択 WHERE " & _
        "日付>=#" & FirstDay & "# AND 日付<=#" & FirstDay + term & "#", _
        dbOpenForwardOnly, dbReadOnly)
    
    Do Until rs.EOF
        If dayBuf <> rs!日付 Then
            j = 1
            dayBuf = rs!日付
        Else
            j = j + 1
        End If

        With Me("T" & rs!日付 - FirstDay + 1 & "_" & j)
            .Caption = .Caption & rs!氏名 & vbCrLf & Format(rs!開始時間, "h:mm") & "～" & Format(rs!終了時間, "h:mm")
        End With
        rs.MoveNext
    Loop
    rs.Close: Set rs = Nothing
        
End Function

tx表示年とtx表示月の値に基づいて日付を設定し、土曜日は青色、日曜日は赤色に書式設定します。

そして１ヶ月間のデータの内容を適したラベルのキャプションとして表示します。

MoveMonth

Private Function MoveMonth(n As Integer)
    Dim D As Date
    D = DateAdd("m", n, DateSerial(Me.tx表示年, Me.tx表示月, 1))
    Me.tx表示年 = Year(D)
    Me.tx表示月 = Month(D)
    SetCalendar
    DoEvents
End Function

btnPrevとbtnNextを押下した時に、tx表示年とtx表示月に対して１ヶ月前後させてカレンダーを再表示します。