カレンダーコントロールの作成(機能追加)
下記リンク先にて作成したカレンダーコントロールの「年」テキストボックスをクリックすると、20年分の「年」一覧が表示され、目的の年をクリックすると「年」テキストボックスに入力されるようにします。スピンボタンをクリックすると前の20年分あるいは次の20年分が表示されます。
【Access VBA】カレンダーコントロールの作成 - カットマンブログ
ラベルコントロールの作成
「年」一覧のラベルを生成するために下記コードを標準モジュールに記述し実行します。宣言セクションのPublic変数は「年」一覧かカレンダーのどちらが表示されているかを判定するために使用します。
Public boolFlag As Boolean '年一覧:TRUE,カレンダー:FALSE
Private Sub ラベルコントロール作成_年ラベル()
DoCmd.OpenForm "Fカレンダー", acDesign
Dim lbl As Control
Dim i As Integer, j As Integer, c As Integer
Const leftMgn As Single = 0.2 '左余白(cm)
Const rightMgn As Single = 0.2 '右余白(cm)
Const topMgn As Single = 1.2 '上余白(cm)
Const bottomMgn As Single = 0.2 '下余白(cm)
Const lblMgn As Single = 0.1 'ラベル間隔(cm)
Const lblWidth As Single = 2.46 'ラベル幅(cm)
Const lblHeight As Single = 1 'ラベル高さ(cm)
Const cmTwip As Single = 567 '1cm当たりのtwip
c = 1
For i = 1 To 7
For j = 1 To 3
Set lbl = CreateControl("Fカレンダー", acLabel, , , , cmTwip * leftMgn + _
cmTwip * (lblWidth + lblMgn) * (j - 1), cmTwip * topMgn _
+ (i - 1) * cmTwip * (lblHeight + lblMgn), _
cmTwip * lblWidth, cmTwip * lblHeight)
With lbl
.BorderColor = vbBlack
.BorderStyle = 1
.ForeColor = vbBlack
.FontSize = 22
.TextAlign = 2
.TopMargin = 50
.Name = "年" & c
c = c + 1
End With
Next
Next
DoCmd.Close acForm, "Fカレンダー", acSaveYes
End Sub「年」テキストボックスをクリックしたときの処理の記述
変数boolFlagがTRUEの場合は「年」一覧を表示し、FALSEの場合はカレンダーを表示します。
Private Sub txtYear_Click()
Dim i As Integer
If boolFlag Then
For i = 1 To 7
Controls("曜日" & i).Visible = True
Next
For i = 1 To 42
Controls("日" & i).Visible = True
Next
For i = 1 To 21
Controls("年" & i).Visible = False
Next
boolFlag = False
Else
For i = 1 To 7
Controls("曜日" & i).Visible = False
Next
For i = 1 To 42
Controls("日" & i).Visible = False
Next
For i = 1 To 21
Controls("年" & i).Visible = True
Controls("年" & i).Caption = Int(Val(txtYear.Value) / 10) * 10 + i - 1 & "年"
Controls("年" & i).Tag = Int(Val(txtYear.Value) / 10) * 10 + i - 1 & "年"
Next
boolFlag = True
End If
End Sub年ラベルをクリックしたときの処理の記述
クラスモジュールにclsYearを作成し、下記のコードを記述します。
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()
mForm.Form.Controls("txtYear") = mLbl.Tag
Dim i As Integer
For i = 1 To 7
mForm.Form.Controls("曜日" & i).Visible = True
Next
For i = 1 To 42
mForm.Form.Controls("日" & i).Visible = True
Next
For i = 1 To 21
mForm.Form.Controls("年" & i).Visible = False
Next
Call mForm.displayLabel(Val(mForm.txtYear), Val(mForm.cboMonth))
boolFlag = False
End Subスピンボタンをクリックしたときの処理の記述
「年」一覧が表示されているときに「年」スピンボタンをクリックすると表示が切り替わるようにコードを修正しました。
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)
Dim i As Integer
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
If TypeName(mCtrl) = "TextBox" Then
Select Case boolFlag
Case True
Select Case mBtn.Tag
Case "Up"
For i = 1 To 21
mForm.Form.Controls("年" & i).Caption = Val(mForm.Form.Controls("年" & i).Tag) + 20 & "年"
mForm.Form.Controls("年" & i).Tag = mForm.Form.Controls("年" & i).Caption
Next
Case "Down"
For i = 1 To 21
mForm.Form.Controls("年" & i).Caption = Val(mForm.Form.Controls("年" & i).Tag) - 20 & "年"
mForm.Form.Controls("年" & i).Tag = mForm.Form.Controls("年" & i).Caption
Next
End Select
Case False
mTxt = lngSpin & mString
End Select
Else
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 If
Call mForm.displayLabel(Val(mForm.txtYear), Val(mForm.cboMonth))
If CDbl(Timer) - startTime < 1 Then
Sleep (300)
Else
Sleep (200)
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カレンダーの読み込み時のイベントプロシージャにコードを追加しました。
「年」ラベル用のクラスのインスタンスを生成し、変数 boolFlagをTrueに設定しました。
Private aClassCalendar() As New clsCalendar
Private aClassSpin(3) As New clsSpin
Private aClassYear() As New clsYear
Private Sub Form_Load()
boolFlag = True
txtYear_Click
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
For i = 1 To 21
ReDim Preserve aClassYear(i)
Call aClassYear(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
