【Access VBA】カレンダーコントロールの作成 - カットマンブログ

【Access VBA】カレンダーコントロールの作成

Access VBA


カレンダーコントロールの作成

ボタンをクリックするとカレンダーコントロールが表示され、カレンダーコントロールの日付をクリックすると、テキストボックスに日付が入力されます。

フォームの作成

フォームを2個用意します。
Fサンプルフォームにテキストボックス1個とボタン1個を配置します。


Fカレンダーフォームにテキストボックス1個、コンボボックス1個、ボタン4個を配置します。
ボタンのタグに「Up」または「Down」を記述します。クラスでどちらのボタンが押されたのか判別するのに使用します。




ラベルコントロールの作成

標準モジュールに下記のコードを記述し、実行するとラベルが生成します。
冒頭の宣言セクションでSleep関数の参照を宣言しています。スピンボタンの処理で使用します。
宣言セクションのPublic変数はカレンダーコントロールで選択した日付を格納するために使います。

Option Compare Database
Option Explicit
#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Public sDate As Date 'カレンダーコントロールで選択した日付を格納する変数
Private Sub ラベルコントロール作成()
    DoCmd.OpenForm "Fカレンダー", acDesign
    Dim lbl As Control
    Dim i As Integer, j As Integer, c As Integer
    Dim dayOfWeek() As Variant
    dayOfWeek = Array("日", "月", "火", "水", "木", "金", "土")
    Const leftMgn As Single = 0.2 '左余白(cm)    
    Const topMgn As Single = 1.2 '上余白(cm)    
    Const lblMgn As Single = 0.1 'ラベル間隔(cm)
    Const lblWidth As Single = 1 'ラベル幅(cm)
    Const lblHeight As Single = 1 'ラベル高さ(cm)
    Const cmTwip As Single = 567 '1cm当たりのtwip
    For i = 1 To 7
        Set lbl = CreateControl("Fカレンダー", acLabel, , , , cmTwip * leftMgn _
                  + (cmTwip * lblWidth + cmTwip * lblMgn) * (i - 1), cmTwip * _
                  topMgn, cmTwip * lblWidth, cmTwip * lblHeight)
        With lbl
            .Caption = dayOfWeek(i - 1)
            .BorderColor = vbBlack
            .BorderStyle = 1
            .ForeColor = vbBlack
            .FontSize = 22
            .TextAlign = 2
            .TopMargin = 50
            .Name = "曜日" & i
        End With
    Next
    c = 1
    For i = 1 To 6
        For j = 1 To 7
            Set lbl = CreateControl("Fカレンダー", acLabel, , , , cmTwip * leftMgn + _
                      cmTwip * (lblWidth + lblMgn) * (j - 1), cmTwip * (topMgn + _
                      lblHeight + lblMgn) + (i - 1) * cmTwip * (lblHeight + lblMgn), _
                      cmTwip * lblWidth, cmTwip * lblHeight)
            With lbl
                .BorderColor = vbBlack
                .BorderStyle = 1
                .Name = "日" & c
                c = c + 1
            End With
        Next
    Next
    
    DoCmd.Close acForm, "Fカレンダー", acSaveYes
    DoCmd.OpenForm "Fカレンダー"
End Sub

日付ラベルをクリックしたときの処理の記述

クラスモジュールにclsCalendarを作成し、下記のコードを記述します。

Option Compare Database
Option Explicit
Private WithEvents mLbl As Label
Private mForm As Form
 
Public Sub Bind(ByVal oCtrl As Control, ByVal oForm As Form)
    Set mLbl = oCtrl
    Set mForm = oForm
    mLbl.OnClick = "[EVENT PROCEDURE]"
End Sub
 
Private Sub mLbl_Click()
    sDate = CDate(mLbl.Tag)
    DoCmd.Close acForm, mForm.Name
End Sub 

スピンボタンをクリックしたときの処理の記述

クラスモジュールにclsSpinを作成し、下記のコードを記述します。

Option Compare Database
Option Explicit
Private WithEvents mBtn As CommandButton
Private mTxt As TextBox
Private mCbo As ComboBox
Private mString As String
Private mForm As Form
Private startTime As Double
Private lngSpin As Long
Private mCtrl As Control

Public Sub Bind(ByVal oCtrl As Control, ByVal oForm As Form, ByVal oString As String, ByVal oCommandButton As CommandButton)
    Set mCtrl = oCtrl
    Set mForm = oForm
    mString = oString
    Set mBtn = oCommandButton
    mBtn.OnMouseDown = "[EVENT PROCEDURE]"
    mBtn.OnMouseUp = "[EVENT PROCEDURE]"
End Sub
 
Private Sub mBtn_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    startTime = CDbl(Timer)
    Select Case TypeName(mCtrl)
    Case "TextBox"
        Set mTxt = mCtrl
        lngSpin = Val(mTxt.Value)
    Case "ComboBox"
        Set mCbo = mCtrl
        lngSpin = Val(mCbo.Value)
    End Select
    
    Do Until startTime = 0
                Select Case mBtn.Tag
                Case "Up" 
                    lngSpin = lngSpin + 1
                Case "Down"
                    lngSpin = lngSpin - 1
                End Select
                
                Select Case TypeName(mCtrl)
                Case "TextBox"
                    mTxt = lngSpin & mString
                Case "ComboBox"
                    If lngSpin > 12 Then
                        lngSpin = 1
                        mForm.txtYear = Val(mForm.txtYear) + 1 & "年"
                    End If
                    If lngSpin < 1 Then
                        lngSpin = 12
                        mForm.txtYear = Val(mForm.txtYear) - 1 & "年"
                    End If
                    mCbo = lngSpin & mString
                End Select
                    
                Call mForm.displayLabel(Val(mForm.txtYear), Val(mForm.cboMonth))
                
                If CDbl(Timer) - startTime < 1 Then
                    Sleep (300)
                Else
                    Sleep (50)
                End If
            DoEvents
    Loop
    startTime = 0
End Sub
 
Private Sub mBtn_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    startTime = 0
End Sub

カレンダー表示用ボタンをクリックしたときの処理の記述

Fサンプルフォームのボタンのイベントプロシージャを記述します。

Option Compare Database
Option Explicit
Private Sub btnCalendar_Click()
        sDate = Nz(txtDate, 0)
        DoCmd.OpenForm "Fカレンダー", , , , , acDialog
        If sDate <> 0 Then
            txtDate = sDate
        End If
End Sub

カレンダーフォーム用コードの記述

Fカレンダーに下記のコードを記述します。
冒頭の宣言セクションでクラスのインスタンスを生成しています。

Option Compare Database
Option Explicit
Private aClassCalendar() As New clsCalendar
Private aClassSpin(3) As New clsSpin
 
Private Sub Form_Load()    
    Dim i As Integer
 
    If sDate = 0 Then
        txtYear = Year(Date) & "年"
        cboMonth = Month(Date) & "月"
    Else
        txtYear = Year(sDate) & "年"
        cboMonth = Month(sDate) & "月"
    End If
 
    Call displayLabel(Val(txtYear), Val(cboMonth))
 
    For i = 1 To 12
        cboMonth.AddItem i & "月"
    Next
    For i = 1 To 42    
        ReDim Preserve aClassCalendar(i)
        Call aClassCalendar(i).Bind(Controls("日" & i), Me)
    Next    
    Call aClassSpin(0).Bind(txtYear, Me, "年", btnUpYear)
    Call aClassSpin(1).Bind(txtYear, Me, "年", btnDownYear)
    Call aClassSpin(2).Bind(cboMonth, Me, "月", btnUpMonth)
    Call aClassSpin(3).Bind(cboMonth, Me, "月", btnDownMonth)
End Sub
 
Private Function getFirst(ByVal lngYear As Long, ByVal intMonth As Integer) As Integer
    '1日の曜日を数字で取得
    Dim dateFirst As Date
    dateFirst = DateSerial(lngYear, intMonth, 1)
    getFirst = Weekday(dateFirst)
End Function
 
Public Sub displayLabel(ByVal lngYear As Long, ByVal intMonth As Integer)
    Dim i As Integer, c As Integer
    Dim intFirstday As Integer
    Dim intLastDay As Integer
    Dim targetDate As Date
    
    'ラベルの表示をクリア
    For i = 1 To 42
        Controls("日" & i).Caption = ""
    Next
    '今月の日付の設定
    c = 1
    intFirstday = getFirst(lngYear, intMonth)
    intLastDay = Day(DateSerial(lngYear, intMonth + 1, 1) - 1) - 1
    For i = intFirstday To intFirstday + intLastDay
        Controls("日" & i).Caption = c
        Controls("日" & i).Tag = CStr(DateSerial(lngYear, intMonth, c))
        Controls("日" & i).ForeColor = vbBlack
        Controls("日" & i).FontSize = 22
        Controls("日" & i).TextAlign = 2
        Controls("日" & i).TopMargin = 50
        c = c + 1
    Next
    '前月の日付の設定
    targetDate = DateSerial(lngYear, intMonth, 1) - 1
    c = Day(targetDate)
    For i = intFirstday - 1 To 1 Step -1
        Controls("日" & i).Caption = c
        Controls("日" & i).Tag = CStr(DateSerial(Year(targetDate), _
                                               Month(targetDate), c))
        Controls("日" & i).ForeColor = &HA29D96
        Controls("日" & i).FontSize = 22
        Controls("日" & i).TextAlign = 2
        Controls("日" & i).TopMargin = 50
        c = c - 1
    Next
    '来月の日付の設定
    targetDate = DateSerial(lngYear, intMonth + 1, 1)
    c = 1
    For i = intFirstday + intLastDay + 1 To 42
        Controls("日" & i).Caption = c
        Controls("日" & i).Tag = CStr(DateSerial(Year(targetDate), _
                                 Month(targetDate), c))
        Controls("日" & i).ForeColor = &HA29D96
        Controls("日" & i).FontSize = 22
        Controls("日" & i).TextAlign = 2
        Controls("日" & i).TopMargin = 50
        c = c + 1
    Next
    '今日の日付のラベルの境界線色を赤色に設定
    If lngYear = Year(Date) And intMonth = Month(Date) Then
        Controls("日" & Day(Date) + getFirst(Year(Date), Month(Date)) - 1).BorderColor _
        = vbRed
    Else
        Controls("日" & Day(Date) + getFirst(Year(Date), Month(Date)) - 1).BorderColor _
        = vbBlack
    End If
End Sub

Private Sub cboMonth_Change()
    Call displayLabel(Val(txtYear), Val(cboMonth))
End Sub