カレンダーコントロールの作成
ボタンをクリックするとカレンダーコントロールが表示され、カレンダーコントロールの日付をクリックすると、テキストボックスに日付が入力されます。
標準モジュールに下記のコードを記述し、実行するとラベルが生成します。
冒頭の宣言セクションで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
