Accessでカレンダーフォームを作る

この記事はAccess2016を使用しております。

ActiveXコントロールの「Microsoft Date and Time Picker Control 6.0」を使えばシンプルでスッキリしたデザインのコントロールが使えます。

しかし、Windows10のアップデートにより表示が崩れたり、そもそも今後サポートされなくなったりするかもしれません。

そこで、同じような動きをするフォームを作ってみました。

# 完成図
テキストボックスをクリックするとカレンダーフォームが表示され、カレンダーフォームで日付を選択すると、テキストボックスの内容が変化すると言うフォームを作りました。
ちなみにAccess2000以降に対応しています。

![image.png](https://qiita-image-store.s3.amazonaws.com/0/89730/10f7aa2b-37db-6745-e955-f667bd7d27fc.png)

# フォームを作る
![image.png](https://qiita-image-store.s3.amazonaws.com/0/89730/30264d69-2d7a-2896-2810-ca955634b229.png)

フォームの構成はラベルを除き次の通りです。

|種類|名前|用途|
|:--|:--|:--|
|コマンドボタン|YearUpButton|一年増やす|
|コマンドボタン|YearDownButton|一年減らす|
|コマンドボタン|MonthUpButton|一月増やす|
|コマンドボタン|MonthDownButton|一月減らす|
|オプショングループ|Days|日の選択|
|トグルボタン|DayTgl1_[1-6]|日曜日の週|
|トグルボタン|DayTgl2_[1-6]|月曜日の週|
|トグルボタン|DayTgl3_[1-6]|火曜日の週|
|トグルボタン|DayTgl4_[1-6]|水曜日の週|
|トグルボタン|DayTgl5_[1-6]|木曜日の週|
|トグルボタン|DayTgl6_[1-6]|金曜日の週|
|トグルボタン|DayTgl7_[1-6]|土曜日の週|
|テキストボックス|NowTextBox|今日の日付を表示|
|テキストボックス|YearTextbox|選択されている年を表示|
|テキストボックス|MonthTextbox|選択されている月を表示|
|テキストボックス|SelectedDateTextBox|選択されている日付を表示|

トグルボタンのオプション値

|日|月|火|水|木|金|土|
|:-:|:-:|:-:|:-:|:-:|:-:|:-:|
|11|21|31|41|51|61|71|
|12|22|32|42|52|62|72|
|13|23|33|43|53|63|73|
|14|24|34|44|54|64|74|
|15|25|35|45|55|65|75|
|16|26|36|46|56|66|76|

# コードの全容

```vbnet:CalenderForm.cls
Option Compare Database
Option Explicit

Public Selected_Date As Date
Public Form_Name As String
Public Date_Control_Name As String

' /// 2017/7/31 カレンダーフォームVer2

' /// Copyright (c) 2017 redoriva
' /// Released under the MIT license
' /// http://opensource.org/licenses/mit-license.php

' /// 使用上の注意
' /// このフォームを開く時 OpenArgs には"フォーム名,日付コントロール名"を代入して下さい。

' 日付を返す
Private Sub SetDate()
    Forms(Form_Name).Controls(Date_Control_Name).Value = Format(Selected_Date, "yyyy/mm/dd")
End Sub

' オプショングループに配置したトグルをクリックして更新した後の処理
Private Sub Days_AfterUpdate()
    Dim week_count As Integer
    Dim week_zone_count As Integer
    
    week_count = Left(CStr(Days), 1)
    week_zone_count = Right(CStr(Days), 1)
    
    Dim day_count As Integer
    
    day_count = Me("DayTgl" & week_count & "_" & week_zone_count).Caption
    
    Selected_Date = DateSerial(Me.YearTextbox.Value, Me.MonthTextbox.Value, day_count)
    
    If week_zone_count = 1 And day_count >= 8 Then
        '1週目で8以上の数値は先月扱いとする
        Selected_Date = DateAdd("M", -1, Selected_Date)
        Me.SelectedDateTextBox.Value = Selected_Date
        Me.YearTextbox.Value = Year(Selected_Date)
        Me.MonthTextbox.Value = Month(Selected_Date)
        Call CalenderCreate
    ElseIf week_zone_count >= 5 And day_count <= 15 Then
        '5週目移行で15以下の数値は来月扱いとする
        Selected_Date = DateAdd("M", 1, Selected_Date)
        Me.SelectedDateTextBox.Value = Selected_Date
        Me.YearTextbox.Value = Year(Selected_Date)
        Me.MonthTextbox.Value = Month(Selected_Date)
        Call CalenderCreate
    Else
        Me.SelectedDateTextBox.Value = Selected_Date
    End If
    
    Call SetDate
End Sub

' フォームを開いた時の処理
Private Sub Form_Open(Cancel As Integer)
    On Error GoTo err1

    Form_Name = Split(OpenArgs, ",")(0)
    Date_Control_Name = Split(OpenArgs, ",")(1)

    Me.NowTextBox.Value = Format(Now(), "今日:yyyy\年m\月d日(aaa)")
    
    If IsDate(Forms(Form_Name).Controls(Date_Control_Name).Value) = True Then
        Selected_Date = Forms(Form_Name).Controls(Date_Control_Name).Value
        Me.SelectedDateTextBox.Value = Format(Selected_Date, "選択日:yyyy\年m\月d日(aaa)")
        Me.YearTextbox.Value = Year(Selected_Date)
        Me.MonthTextbox.Value = Month(Selected_Date)
    Else
        Selected_Date = Now()
        Me.SelectedDateTextBox.Value = Format(Selected_Date, "選択日:yyyy\年m\月d日(aaa)")
        Me.YearTextbox.Value = Year(Now)
        Me.MonthTextbox.Value = Month(Now)
    End If
    
    Call CalenderCreate
    
    Call SetDate
Exit Sub
err1:
    MsgBox "OpenArgsが正しくセットされていない為、処理を中止します。" & vbNewLine & "Docmd.OpenFormのOpenArgsにはフォーム名,日付で使うコントロール名として下さい。", vbOKOnly + vbCritical, "処理中断"
    DoCmd.Close acForm, "CalenderForm"
End Sub

' トグルボタンの日付をセットする処理
Private Sub CalenderCreate()
    'まず1日が何曜日かセットする
    '1:日～7:土
    Dim first_day As Date
    Dim first_day_week As Integer
    Dim week_count As Integer
    Dim week_zone_count As Integer
    Dim date_count As Date
    
    first_day = DateSerial(Me.YearTextbox.Value, Me.MonthTextbox.Value, 1)
    first_day_week = Weekday(first_day, vbSunday)
    
    Me("DayTgl" & first_day_week & "_1").Caption = 1
    Me("DayTgl" & first_day_week & "_1").ForeColor = RGB(0, 0, 0)
    
    '1日以前の日付をセットする
    If first_day_week > 1 Then
        week_count = 0
        For week_count = 1 To first_day_week - 1
            date_count = first_day - (first_day_week - week_count)
            Me("DayTgl" & week_count & "_1").Caption = Day(date_count)
            Me("DayTgl" & week_count & "_1").ForeColor = RGB(150, 150, 150)
        Next
    End If
    
    '1日移行の日付をセットする
    If first_day_week < 7 Then
        week_count = 0
        For week_count = first_day_week + 1 To 7
            date_count = first_day - (first_day_week - week_count)
            Me("DayTgl" & week_count & "_1").Caption = Day(date_count)
            Me("DayTgl" & week_count & "_1").ForeColor = RGB(0, 0, 0)
        Next
    Else
        date_count = first_day
    End If
    
    '2週目移行の日付をセットする
    For week_zone_count = 2 To 6
        week_count = 0
        For week_count = 1 To 7
            date_count = DateAdd("D", 1, date_count)
            Me("DayTgl" & week_count & "_" & week_zone_count).Caption = Day(date_count)
            
            If Month(date_count) = Month(first_day) Then
                Me("DayTgl" & week_count & "_" & week_zone_count).ForeColor = RGB(0, 0, 0)
            Else
                Me("DayTgl" & week_count & "_" & week_zone_count).ForeColor = RGB(150, 150, 150)
            End If
        Next
    Next
    
    Call DaySelect
End Sub

' 先月に移動
Private Sub MonthDownButton_Click()
    Selected_Date = DateAdd("M", -1, Selected_Date)
    Me.SelectedDateTextBox.Value = Selected_Date
    Me.YearTextbox.Value = Year(Selected_Date)
    Me.MonthTextbox.Value = Month(Selected_Date)
    Call CalenderCreate
    Call SetDate
End Sub

' 翌月に移動
Private Sub MonthUpButton_Click()
    Selected_Date = DateAdd("M", 1, Selected_Date)
    Me.SelectedDateTextBox.Value = Selected_Date
    Me.YearTextbox.Value = Year(Selected_Date)
    Me.MonthTextbox.Value = Month(Selected_Date)
    Call CalenderCreate
    Call SetDate
End Sub

' 去年に移動
Private Sub YearDownButton_Click()
    Selected_Date = DateAdd("yyyy", -1, Selected_Date)
    Me.SelectedDateTextBox.Value = Selected_Date
    Me.YearTextbox.Value = Year(Selected_Date)
    Me.MonthTextbox.Value = Month(Selected_Date)
    Call CalenderCreate
    Call SetDate
End Sub

' 来年に移動
Private Sub YearUpButton_Click()
    Selected_Date = DateAdd("yyyy", 1, Selected_Date)
    Me.SelectedDateTextBox.Value = Selected_Date
    Me.YearTextbox.Value = Year(Selected_Date)
    Me.MonthTextbox.Value = Month(Selected_Date)
    Call CalenderCreate
    Call SetDate
End Sub

'現在の選択日からトグルの日付をセットする
Private Sub DaySelect()
    Dim week_count As Integer
    Dim week_zone_count As Integer
    Dim day_count As Integer
    
    For week_zone_count = 1 To 6
        For week_count = 1 To 7
            day_count = Me("DayTgl" & week_count & "_" & week_zone_count).Caption
            If week_zone_count = 1 And day_count >= 8 Then
                '1週目で8以上の数値は先月扱いとする
            ElseIf week_zone_count >= 5 And day_count <= 15 Then
                '5週目移行で15以下の数値は来月扱いとする
            Else
                If day_count = Day(Selected_Date) Then
                    Me.Days.Value = Me("DayTgl" & week_count & "_" & week_zone_count).OptionValue
                    Exit Sub
                End If
            End If
        Next
    Next
End Sub
```

# 使い方
フォームを開く時にOpenArgsに日付で使うフォーム名とテキストボックスの名前をセットする事で連携を実現しています。

```vbnet:TestForm.cls
Private Sub DateTextBox_Click()
    DoCmd.OpenForm "CalenderForm", acNormal, , , , , "TestForm,DateTextBox"
End Sub
```

# その他
選択後にフォームを閉じる動作を行わせたい場合は

```vbnet:CalenderForm.cls
Private Sub SetDate()
    Forms(Form_Name).Controls(Date_Control_Name).Value = Format(Selected_Date, "yyyy/mm/dd")
    DoCmd.Close acForm, Me.Name
End Sub
```

とすれば良さそうに見えますが、
これだと最初から選択されている日付をクリックした時に閉じませんので
カレンダーのトグルボタン全てに MouseDownイベント を設定する必要があります。

# おわりに
Excelもそうですけどカレンダーを再現するのって結構良い練習になるなぁと思いました。