#カレンダーフォームをクリックして日付入力
Excelの日付入力をカレンダーフォームの日付クリックで入力したい。
昔(調べてみると2007までは、標準であったようです。)は出来ていたようなのですが、
最近は出来なくなったようで、excel calendar form とかで検索するとヒントやダウンロードできるものが
たくさん見つかりました。
Access2007(Access2007runtime)が前提で優しく解説されているものが見つかりますが、runtimeのダウンロードすらできません。
Access2007があれば、こんな感じになります。
セルの書式設定(yyyy/mm/dd (aaa))でカレンダー表示判定し、そのセルの直下にカレンダーを表示する。
セルの日付をカレンダー表示の初期値にする。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range(Target.Address).NumberFormatLocal = "yyyy/mm/dd (aaa)" Then
ActiveSheet.Calendar1.Top = Target.Offset(1, 0).Top
ActiveSheet.Calendar1.Left = Target.Offset(1, 0).Left
If IsDate(Range(Target.Address)(1).Value) Then
ActiveSheet.Calendar1.Year = Year(Range(Target.Address)(1).Value)
ActiveSheet.Calendar1.Month = Month(Range(Target.Address)(1).Value)
ActiveSheet.Calendar1.Day = Day(Range(Target.Address)(1).Value)
Else
ActiveSheet.Calendar1.Year = Year(Now)
ActiveSheet.Calendar1.Month = Month(Now)
ActiveSheet.Calendar1.Day = Day(Now)
End If
ActiveSheet.Calendar1.Visible = True ' カレンダーフォームを起動する
Else
ActiveSheet.Calendar1.Visible = False
End If
End Sub
Private Sub Calendar1_Click()
Selection.Value = Calendar1.Value
ActiveSheet.Calendar1.Visible = False
End Sub
#カレンダーフォーム作成
カレンダーフォーム作成では大変お世話になりました。
老眼にはキツイ作業でした。
#カレンダーフォームをマクロで作成する
老眼でも頑張れるかもと思わせるのもです。
発想的には
1.フォームはマクロで作成
2.使い終わったらマクロで消す
3.最小限のマクロで動作する
祝祭日判定なしですが、フォーム生成から消去までやっているので、フォームが残ったりはしません。
消去は多少強引ですが。。。
###作ってみて
やってみて思うのは、フォームは自動生成するものでは無いな!
ただし、フォームの作成が、マクロから出来ると、老眼には優しい
たくさんのページを参考にして、動作するものが出来たので、メモ的に残します。
1.sheetマクロ
こうすると、カレンダ表示が書式で制御できて、EXCEL側の入力ミスも減る?
セルの書式を判定して、カレンダーフォームを起動しています。
Private Sub Worksheet_SelectionChange(ByVal target As Range)
If Range(target.Address).NumberFormatLocal = "yyyy/mm/dd (aaa)" Then
Call CalendarModule.open_calendar(target) ' カレンダーフォームを起動する
Exit Sub
End If
End Sub
2.クラスモジュール
ControlSetting として 保存
イベント発生と処理を標準モジュールで記述したかったのですが、
その方法が見つからず、断念しました。
カレンダーフォームで作成した、ラベルやボタンでイベントが発生すると、ここが呼ばれます。
Option Explicit
Public WithEvents Label As MSForms.Label ' ラベル
Public WithEvents ComboBox As MSForms.ComboBox ' 日付ラベル
Public Sub LabelNewClass(ByVal objLabel As MSForms.Label)
Set Label = objLabel
End Sub
Public Sub ComboBoxNewClass(ByVal objComboBox As MSForms.ComboBox)
Set ComboBox = objComboBox
End Sub
Private Sub Label_Click()
Select Case True
Case Label.Name = "LBL_PREV"
Call LblMonthClick(-1) '前月
Case Label.Name = "LBL_NEXT"
Call LblMonthClick(1) '翌月
Case Label.Name = "LBL_YM"
Call LblYMClick
Case Label.Name Like "LBL_DD*"
Call LblDDClick(Mid(Me.Label.Name, 7))
End Select
End Sub
Private Sub ComboBox_Change()
If ComboBox.Text = "" Then Exit Sub
If Not (Me.ComboBox.Visible) Then Exit Sub
Select Case ComboBox.Name
Case "CBO_YEAR", "CBO_MONTH"
Call CobYMChange
End Select
End Sub
3.標準モジュール
フォームの作成、カレンダーの更新、いろりろやってます。
Option Explicit
Private Const cnsSyear = 1900 '対応年 はじめ
Private Const cnsEyear = 2100 '対応年 終わり
' フォーム上の色指定等の定数
Private Const cnsBC_Select = &HFFCC33 ' 選択日付の背景色
Private Const cnsBC_Other = &HE0E0E0 ' 当月以外の背景色
Private Const cnsBC_Sunday = &HFFDDFF ' 日曜の背景色
Private Const cnsBC_Saturday = &HDDFFDD ' 土曜の背景色
Private Const cnsBC_Month = &HFFFFFF ' 当月土日以外の背景色
Private Const cnsFC_Normal = &HC00000 ' 文字色
Public LBL_PREV As MSForms.Label ' ←
Public LBL_NEXT As MSForms.Label ' →
Public LBL_YM As MSForms.Label ' 年月
Public CBO_YEAR As MSForms.ComboBox ' 年
Public CBO_MONTH As MSForms.ComboBox ' 月
Public LBL_DD(1 To 42) As MSForms.Label ' 日
Public days(1 To 42) As Date
Public newFormName As String ' formName
Public myForm ' As UserForm1
Public nowCalendarDate As Date ' 現在表示カレンダー日付 常に月初
Public CalendarFormNo As Integer ' UserForm 名称変更後同じ名前を使うとERRになる
Public reTarget As Range
'form生成
Sub open_calendar(target As Range)
' Debug.Print "open_calendar:" & newFormName
Set reTarget = target ' 呼び元
'*************
'イベント
'← yyyy年mm月 →
Dim oLBL_PREV As Object
Dim oLBL_NEXT As Object
Dim oLBL_YM As Object
Set oLBL_PREV = New ControlSetting
Set oLBL_NEXT = New ControlSetting
Set oLBL_YM = New ControlSetting
'yyyy mm
Dim oCBO_YEAR As Object
Dim oCBO_MONTH As Object
Set oCBO_YEAR = New ControlSetting
Set oCBO_MONTH = New ControlSetting
'dd
Dim oLBL_DD(1 To 42) As Object
Dim vbcomp
Dim eform
'カレンダーフォーム作成
eform = False
If Not (newFormName = "") Then
With ThisWorkbook.VBProject
For Each vbcomp In .VBComponents
If vbcomp.Name = newFormName And vbcomp.Type = 3 Then
eform = True
Exit For
End If
Next
End With
End If
If Not (eform) Then newFormName = MSFormAdd()
Set myForm = UserForms.Add(newFormName)
'セルデータ取得
Dim myDate As Date
If (IsDate(target.Value)) Then
myDate = CDate(target.Value)
Else
myDate = Date
End If
With myForm
'← 年 月 →
Set LBL_PREV = .Controls.Add("Forms.Label.1", "LBL_PREV", True)
With LBL_PREV
.BackColor = &H99CCCC
.BorderColor = &H808080
.ForeColor = &H808080
.Height = 11.25
.Width = 14.75 '16.75
.Left = 1 '3
.Top = 1
.Font.Size = 11
.Caption = "←"
.TextAlign = fmTextAlignCenter
' Debug.Print .Name
End With
Call oLBL_PREV.LabelNewClass(LBL_PREV)
Set LBL_NEXT = .Controls.Add("Forms.Label.1", "LBL_NEXT", True)
With LBL_NEXT
.BackColor = &H99CCCC
.BorderColor = &H808080
.ForeColor = &H808080
.Height = 11.25
.Width = 14.75 '17
.Left = 103.5 '108
.Top = 1
.Font.Size = 11
.Caption = "→"
.TextAlign = fmTextAlignCenter
End With
Call oLBL_NEXT.LabelNewClass(LBL_NEXT)
Set CBO_YEAR = .Controls.Add("Forms.ComboBox.1", "CBO_YEAR", True)
With CBO_YEAR
.BackColor = &H80000005
.BorderColor = &H80000006
.Height = 13
.Width = 38
.Left = 29 '31
.Top = 0
.Font.Size = 8
.TextAlign = fmTextAlignLeft
.TextColumn = -1
.IMEMode = fmIMEModeDisable
.ListWidth = 38
.Text = Year(myDate)
End With
Call oCBO_YEAR.ComboBoxNewClass(CBO_YEAR)
Set CBO_MONTH = .Controls.Add("Forms.ComboBox.1", "CBO_MONTH", True)
With CBO_MONTH
.BackColor = &H80000005
.BorderColor = &H80000006
.Height = 13
.Width = 32
.Left = 66 '68
.Top = 0
.Font.Size = 8
.TextAlign = fmTextAlignLeft
.TextColumn = -1
.IMEMode = fmIMEModeDisable
.ListWidth = 30
.Text = Format(Month(myDate), "00")
End With
Call oCBO_MONTH.ComboBoxNewClass(CBO_MONTH)
Set LBL_YM = .Controls.Add("Forms.Label.1", "LBL_YM", True)
With LBL_YM
.BackColor = &HFFCCCC
.BorderColor = &HC0C0&
.ForeColor = &H800080
.Height = 11.25
.Width = 86.5
.Left = 16.5 '20.5
.Top = 1
.Font.Size = 11
.Caption = ""
.TextAlign = fmTextAlignCenter
End With
Call oLBL_YM.LabelNewClass(LBL_YM)
'日月火水木金土
Dim weekLabel(0 To 6) As Object
Dim weekdays As String
weekdays = "日月火水木金土"
Dim weekdaysi As Integer
For weekdaysi = 0 To 6
Set weekLabel(weekdaysi) = .Controls.Add("Forms.Label.1", "weekLabel" & weekdaysi)
With weekLabel(weekdaysi)
.Height = 10
.Width = 16.75
.Left = 1 + weekdaysi * 17
.Top = 13
.Font.Size = 9
.ForeColor = cnsFC_Normal
.TextAlign = fmTextAlignCenter
.Caption = Mid(weekdays, weekdaysi + 1, 1)
Select Case weekdaysi
Case 0
.BackColor = cnsBC_Sunday
Case 6
.BackColor = cnsBC_Saturday
Case Else
.BackColor = cnsBC_Month
End Select
End With
Next weekdaysi
'7日×6週
Dim dayi As Integer
For dayi = 1 To 42
Set oLBL_DD(dayi) = New ControlSetting
Set LBL_DD(dayi) = .Controls.Add("Forms.Label.1", "LBL_DD" & dayi, True)
With LBL_DD(dayi)
.Height = 10
.Width = 16.75
.Top = 24 + ((dayi - 1) \ 7) * 10.25
.Left = 1 + ((dayi - 1) Mod 7) * 17
.TextAlign = fmTextAlignCenter
.Caption = dayi
End With
Call oLBL_DD(dayi).LabelNewClass(LBL_DD(dayi))
Next dayi
Call calendarSet(myDate) 'カレンダー作成
.Show
End With
End Sub
'カレンダー作成
Private Sub calendarSet(myDate As Date)
Dim wDate As Date
Dim dayi As Integer
Dim weekNo As Integer
Dim endDay As Integer
With myForm
For dayi = 1 To 42 'ラベルの初期化
.Controls("LBL_DD" & dayi).Caption = ""
.Controls("LBL_DD" & dayi).BackColor = cnsBC_Other
Next
nowCalendarDate = CDate(Year(myDate) & "/" & Month(myDate) & "/" & 1) '当月1日
endDay = day(DateAdd("d", -1, DateAdd("m", 1, nowCalendarDate))) '月末日の算出
weekNo = Weekday(nowCalendarDate) - 1 '当月1日の曜日番号に、マイナス1したもの
'前月
For dayi = 1 To weekNo
With .Controls("LBL_DD" & weekNo - dayi + 1)
.Caption = day(nowCalendarDate - dayi) '日を入れる
.BackColor = cnsBC_Other
End With
days(weekNo - dayi + 1) = nowCalendarDate - dayi
Next
'当月
For dayi = 1 To endDay
With .Controls("LBL_DD" & dayi + weekNo)
.Caption = dayi '日を入れる
wDate = CDate(Year(myDate) & "/" & Month(myDate) & "/" & dayi)
Select Case Weekday(wDate) - 1
Case 0
.BackColor = cnsBC_Sunday
Case 6
.BackColor = cnsBC_Saturday
Case Else
.BackColor = cnsBC_Month
End Select
'TextBoxの日と同じなら色をつける
If wDate = myDate Then .BackColor = cnsBC_Select
End With
days(dayi + weekNo) = wDate
Next dayi
'翌月
wDate = DateAdd("m", 1, nowCalendarDate)
For dayi = endDay + weekNo + 1 To 42
With .Controls("LBL_DD" & dayi)
.Caption = dayi - (endDay + weekNo) '日を入れる
.BackColor = cnsBC_Other
End With
days(dayi) = wDate + (dayi - (endDay + weekNo)) - 1
Next
LBL_YM.Caption = Year(nowCalendarDate) & "年" & Format(Month(nowCalendarDate), "00") & "月"
Call LBL_YEAR_re(Year(nowCalendarDate))
Call LBL_MONTH_re(Month(nowCalendarDate))
LBL_YM.Visible = True '年月ラベル表示
GpYearMonth False '年、月コンボボックスは非表示
End With
End Sub
'***************
'ユーザフォーム追加
Function MSFormAdd()
Dim newForm As VBIDE.VBComponent
Dim wk
For Each wk In ThisWorkbook.VBProject.VBComponents
If wk.Name Like "CalenderForm*" Then
' Debug.Print wk.Name
newFormName = wk.Name
MSFormRemove
End If
Next
Set newForm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
With newForm
.Properties("Height") = 106
.Properties("Width") = 123
.Properties("Caption") = "日付選択"
On Error Resume Next
Do
CalendarFormNo = CalendarFormNo + 1
.Properties("name") = "CalenderForm" & CalendarFormNo
If Err.Number <> 0 Then
Debug.Print Err.Description
Err.Clear
Else
Exit Do
End If
Loop
On Error GoTo 0
MSFormAdd = .Properties("name")
End With
End Function
'ユーザフォーム削除
Sub MSFormRemove()
Dim vbcomp
If Not (newFormName = "") Then
With ThisWorkbook.VBProject
For Each vbcomp In .VBComponents
If vbcomp.Name = newFormName And vbcomp.Type = 3 Then
' Debug.Print "userform remove is " & newFormName
.VBComponents.Remove .VBComponents(newFormName)
Exit For
End If
Next
End With
End If
End Sub
'***************
'←(前月)→(翌月
Public Sub LblMonthClick(wmonth As Integer)
Call calendarSet(DateAdd("m", wmonth, nowCalendarDate))
Call LBL_YEAR_re(Year(nowCalendarDate))
Call LBL_MONTH_re(Month(nowCalendarDate))
LBL_YM.Visible = True
End Sub
'年
Private Sub LBL_YEAR_re(pYear As Integer)
Dim intYear As Integer
With CBO_YEAR
.Clear
For intYear = cnsSyear To cnsEyear
.AddItem CStr(intYear)
Next
.Visible = False
.ListIndex = pYear - cnsSyear
End With
End Sub
'月
Private Sub LBL_MONTH_re(pMonth As Integer)
Dim intMonth As Integer
With CBO_MONTH
.Clear
For intMonth = 1 To 12
.AddItem Format(intMonth, "00")
Next intMonth
.Visible = False
.ListIndex = pMonth - 1
End With
End Sub
'***************
'年コンボの操作イベント
Public Sub CobYMChange()
Call calendarSet(CDate(CBO_YEAR.Value & "/" & CBO_MONTH.Value & "/1"))
End Sub
'***************
'yyyy年mm月 コンボの非表示化
Public Sub LblYMClick()
LBL_YM.Visible = False
GpYearMonth True
End Sub
'***************
'「年」「月」コンボの表示/非表示化
Private Sub GpYearMonth(visibleSw As Boolean)
CBO_YEAR.Visible = visibleSw
CBO_MONTH.Visible = visibleSw
End Sub
'***************
'日付選択
Public Sub LblDDClick(wdd As String)
reTarget.Value = days(wdd)
myForm.Hide
MSFormRemove '日付選択フォーム削除
End Sub
##たくさんの方のページを参考にしました。
参考した全部のページを書きたいのですが、記録してものだけになります。
ありがとうございました。
カレンダーフォーム
https://ateitexe.com/excel-vba-calendar-control/
表示位置
http://www.ne.jp/asahi/excel/inoue/
http://www.asahi-net.or.jp/~ef2o-inue/download/sub09_020_025.html
MS製
https://hamachan.info/vista/calendar.html
UserFormを作成する
http://touch-sp.hatenablog.com/entry/2017/01/12/144526
http://officetanaka.net/excel/vba/vbe/07.htm
特定のユーザーフォームが存在するかのチェック。
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1473461604
Excel VBA ヒント集
https://qiita.com/muramoto_jp/items/4ba28788a6859eabbf99
Access フォームは開いてるか調べる
http://psp8155.blog13.fc2.com/blog-entry-305.html
Formの表示状態の取得
https://oshiete.goo.ne.jp/qa/4274740.html
開いているすべてのフォームを参照する
https://www.moug.net/tech/acvba/0100037.html
UserFormを変数で操作する
http://officetanaka.net/excel/vba/tips/tips103.htm
[ExcelVBA] UserForm上で複数コントロールを動的に追加&イベント検出する
https://ateitexe.com/excel-vba-add-userform-control/
ユーザーフォームに動的にボタン等を追加する
https://www.excellovers.com/entry/2017/07/30/155613
UserForm上で複数コントロールを動的に追加&イベント検出する
https://ateitexe.com/excel-vba-add-userform-control/
VBEのモジュールを参照する(VBComponents コレクション)
https://excelwork.info/excel/vbcomponents/
ユーザフォームをコードから作成する
https://www.moug.net/tech/exvba/0090027.html
VBA:コードの自動生成
ボタンのクリックイベントプロシージャを作成
http://blog.livedoor.jp/yorinaga/archives/51924953.html
モジュール内のコードを操作する(CodeModule のメソッド)
https://excelwork.info/excel/codemodulemethod/
物忘れ防止 calendar_v1.xlsm
https://github.com/sugita0301/douzo
UserFormをマクロで作成する
UserFormをマクロで作成してみました。
UserFormをパラメータ(表示位置、サイズ、カラー)指定をマクロで行える点は(老眼だからか)使える!と感じました。
しかし、イベント登録のやり方がわからない、いろいろ設定が必要だったりして、実用的では無いと判断した。
##「マクロでフォームを作って保存」メモ
'form生成
Sub formCreate(formName As String)
Dim LBL_PREV As Control
Dim LBL_NEXT As Control
Dim CBO_YEAR As Control
Dim CBO_MONTH As Control
Dim LBL_YM As Control
Dim weekLabel(0 To 6) As Control
Dim LBL_DD(1 To 42) As Control
Dim newForm As VBIDE.VBComponent
Set newForm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
With newForm
.Properties("Height") = 106
.Properties("Width") = 123
.Properties("Caption") = "日付選択"
'.Properties("Name") = formName 'コメントにすると UserForm〇〇 になる
'← 年 月 →
Set LBL_PREV = .Designer.Controls.Add("Forms.Label.1", "LBL_PREV", True)
With LBL_PREV
.BackColor = &H99CCCC
.BorderColor = &H808080
.ForeColor = &H808080
.Height = 11.25
.Width = 14.75 '16.75
.Left = 1 '3
.Top = 1
.Font.Size = 11
.Caption = "←"
.TextAlign = fmTextAlignCenter
End With
Set LBL_NEXT = .Designer.Controls.Add("Forms.Label.1", "LBL_NEXT", True)
With LBL_NEXT
.BackColor = &H99CCCC
.BorderColor = &H808080
.ForeColor = &H808080
.Height = 11.25
.Width = 14.75 '17
.Left = 103.5 '108
.Top = 1
.Font.Size = 11
.Caption = "→"
.TextAlign = fmTextAlignCenter
End With
Set CBO_YEAR = .Designer.Controls.Add("Forms.ComboBox.1", "CBO_YEAR", True)
With CBO_YEAR
.BackColor = &H80000005
.BorderColor = &H80000006
.Height = 12
.Width = 38
.Left = 29 '31
.Top = 1
.Font.Size = 8
.TextAlign = fmTextAlignLeft
.TextColumn = -1
.IMEMode = fmIMEModeDisable
.ListWidth = 38
.Text = Year(myDate)
End With
Set CBO_MONTH = .Designer.Controls.Add("Forms.ComboBox.1", "CBO_MONTH", True)
With CBO_MONTH
.BackColor = &H80000005
.BorderColor = &H80000006
.Height = 12
.Width = 32
.Left = 66 '68
.Top = 1
.Font.Size = 8
.TextAlign = fmTextAlignLeft
.TextColumn = -1
.IMEMode = fmIMEModeDisable
.ListWidth = 30
.Text = Format(Month(myDate), "00")
End With
Set LBL_YM = .Designer.Controls.Add("Forms.Label.1", "LBL_YM", True)
With LBL_YM
.BackColor = &HFFCCCC
.BorderColor = &HC0C0&
.ForeColor = &H800080
.Height = 11.25
.Width = 86.5
.Left = 16.5 '20.5
.Top = 1
.Font.Size = 11
.Caption = ""
.TextAlign = fmTextAlignCenter
End With
'日月火水木金土
Dim weekdays As String
weekdays = "日月火水木金土"
Dim weekdaysi As Integer
For weekdaysi = 0 To 6
Set weekLabel(weekdaysi) = .Designer.Controls.Add("Forms.Label.1", "weekLabel" & weekdaysi)
With weekLabel(weekdaysi)
.Height = 10
.Width = 16.75
.Left = 1 + weekdaysi * 17
.Top = 13
.Font.Size = 9
.ForeColor = cnsFC_Normal
.TextAlign = fmTextAlignCenter
.Caption = Mid(weekdays, weekdaysi + 1, 1)
Select Case weekdaysi
Case 0
.BackColor = cnsBC_Sunday
Case 6
.BackColor = cnsBC_Saturday
Case Else
.BackColor = cnsBC_Month
End Select
End With
Next weekdaysi
'7日×6週
Dim dayi As Integer
For dayi = 1 To 42
Set LBL_DD(dayi) = .Designer.Controls.Add("Forms.Label.1", "LBL_DD" & dayi, True)
With LBL_DD(dayi)
.Height = 10
.Width = 16.75
.Top = 24 + ((dayi - 1) \ 7) * 10.25
.Left = 1 + ((dayi - 1) Mod 7) * 17
.TextAlign = fmTextAlignCenter
.Caption = dayi
End With
Next dayi
End With
End Sub
フォーム名が存在するとエラーになる
.Properties("Name") = formName 'コメントにすると UserForm〇〇 になる
起動はsheetにこのマクロを置いて、セルをクリック
Private Sub Worksheet_SelectionChange(ByVal target As Range)
formCreate ("fromCalendar") ' カレンダーフォームを起動する
End Sub
物忘れ防止 calendar_v2_UserForm.xlsm
https://github.com/sugita0301/douzo
UserFormを使ってみる
物忘れ防止 calendar_v3_event.xlsm
https://github.com/sugita0301/douzo
1.sheetにはいつもの起動マクロ
'''vba:Worksheet_SelectionChange
Private Sub Worksheet_SelectionChange(ByVal target As Range)
If Range(target.Address).NumberFormatLocal = "yyyy/mm/dd (aaa)" Then
Call CalendarModule.open_calendar(target) ' カレンダーフォームを起動する
Exit Sub
End If
End Sub
2.フォームのマクロ
Option Explicit
Public cmbYMevent As Boolean
Private Const cnsSyear = 1900 '対応年 はじめ
Private Const cnsEyear = 2100 '対応年 終わり
Private Sub UserForm_Initialize() 'Formが開くとき
Dim i As Integer
For i = cnsSyear To cnsEyear
Me.CBO_YEAR.AddItem i
Next i
For i = 1 To 12 '月を登録
Me.CBO_MONTH.AddItem Format(i, "00")
Next i
cmbYMevent = True
End Sub
'-- イベント処理
Private Sub LBL_PREV_Click() '←(前月)
CalendarModule.LblMonthClick -1
End Sub
Private Sub LBL_NEXT_Click() '→(翌月)
CalendarModule.LblMonthClick 1
End Sub
Private Sub LBL_YM_Click() 'yyyy年mm月
CalendarModule.LblYMClick
End Sub
Private Sub CBO_YEAR_Change() '年コンボ
If cmbYMevent Then CalendarModule.CmbYMChange CDate(CBO_YEAR.Value & "/" & CBO_MONTH.Value & "/1")
End Sub
'月コンボ
Private Sub CBO_MONTH_Change()
If cmbYMevent Then CalendarModule.CmbYMChange CDate(CBO_YEAR.Value & "/" & CBO_MONTH.Value & "/1")
End Sub
'日
Private Sub LBL_DD1_Click(): Call CalendarModule.LblDDClick(1): End Sub
Private Sub LBL_DD2_Click(): Call CalendarModule.LblDDClick(2): End Sub
Private Sub LBL_DD3_Click(): Call CalendarModule.LblDDClick(3): End Sub
Private Sub LBL_DD4_Click(): Call CalendarModule.LblDDClick(4): End Sub
Private Sub LBL_DD5_Click(): Call CalendarModule.LblDDClick(5): End Sub
Private Sub LBL_DD6_Click(): Call CalendarModule.LblDDClick(6): End Sub
Private Sub LBL_DD7_Click(): Call CalendarModule.LblDDClick(7): End Sub
Private Sub LBL_DD8_Click(): Call CalendarModule.LblDDClick(8): End Sub
Private Sub LBL_DD9_Click(): Call CalendarModule.LblDDClick(9): End Sub
Private Sub LBL_DD10_Click(): Call CalendarModule.LblDDClick(10): End Sub
Private Sub LBL_DD11_Click(): Call CalendarModule.LblDDClick(11): End Sub
Private Sub LBL_DD12_Click(): Call CalendarModule.LblDDClick(12): End Sub
Private Sub LBL_DD13_Click(): Call CalendarModule.LblDDClick(13): End Sub
Private Sub LBL_DD14_Click(): Call CalendarModule.LblDDClick(14): End Sub
Private Sub LBL_DD15_Click(): Call CalendarModule.LblDDClick(15): End Sub
Private Sub LBL_DD16_Click(): Call CalendarModule.LblDDClick(16): End Sub
Private Sub LBL_DD17_Click(): Call CalendarModule.LblDDClick(17): End Sub
Private Sub LBL_DD18_Click(): Call CalendarModule.LblDDClick(18): End Sub
Private Sub LBL_DD19_Click(): Call CalendarModule.LblDDClick(19): End Sub
Private Sub LBL_DD20_Click(): Call CalendarModule.LblDDClick(20): End Sub
Private Sub LBL_DD21_Click(): Call CalendarModule.LblDDClick(21): End Sub
Private Sub LBL_DD22_Click(): Call CalendarModule.LblDDClick(22): End Sub
Private Sub LBL_DD23_Click(): Call CalendarModule.LblDDClick(23): End Sub
Private Sub LBL_DD24_Click(): Call CalendarModule.LblDDClick(24): End Sub
Private Sub LBL_DD25_Click(): Call CalendarModule.LblDDClick(25): End Sub
Private Sub LBL_DD26_Click(): Call CalendarModule.LblDDClick(26): End Sub
Private Sub LBL_DD27_Click(): Call CalendarModule.LblDDClick(27): End Sub
Private Sub LBL_DD28_Click(): Call CalendarModule.LblDDClick(28): End Sub
Private Sub LBL_DD29_Click(): Call CalendarModule.LblDDClick(29): End Sub
Private Sub LBL_DD30_Click(): Call CalendarModule.LblDDClick(30): End Sub
Private Sub LBL_DD31_Click(): Call CalendarModule.LblDDClick(31): End Sub
Private Sub LBL_DD32_Click(): Call CalendarModule.LblDDClick(32): End Sub
Private Sub LBL_DD33_Click(): Call CalendarModule.LblDDClick(33): End Sub
Private Sub LBL_DD34_Click(): Call CalendarModule.LblDDClick(34): End Sub
Private Sub LBL_DD35_Click(): Call CalendarModule.LblDDClick(35): End Sub
Private Sub LBL_DD36_Click(): Call CalendarModule.LblDDClick(36): End Sub
Private Sub LBL_DD37_Click(): Call CalendarModule.LblDDClick(37): End Sub
Private Sub LBL_DD38_Click(): Call CalendarModule.LblDDClick(38): End Sub
Private Sub LBL_DD39_Click(): Call CalendarModule.LblDDClick(39): End Sub
Private Sub LBL_DD40_Click(): Call CalendarModule.LblDDClick(40): End Sub
Private Sub LBL_DD41_Click(): Call CalendarModule.LblDDClick(41): End Sub
Private Sub LBL_DD42_Click(): Call CalendarModule.LblDDClick(42): End Sub
3.標準モジュール
Option Explicit
' フォーム上の色指定等の定数
Private Const cnsBC_Select = &HFFCC33 ' 選択日付の背景色
Private Const cnsBC_Other = &HE0E0E0 ' 当月以外の背景色
Private Const cnsBC_Sunday = &HFFDDFF ' 日曜の背景色
Private Const cnsBC_Saturday = &HDDFFDD ' 土曜の背景色
Private Const cnsBC_Month = &HFFFFFF ' 当月土日以外の背景色
Private days(1 To 42) As Date
Private nowCalendarDate As Date ' 現在表示カレンダー日付 常に月初
Private targetDate As Date
Private retarget As Range
'---- form生成
Public Sub open_calendar(target As Range)
Set retarget = target '日クリックの返し先
If (IsDate(target.Value)) Then 'セルデータ取得
targetDate = CDate(target.Value)
Else
targetDate = Date
End If
calendarSet targetDate 'カレンダー作成
fromCalendar.Show
End Sub
'---- カレンダー作成
Private Sub calendarSet(calendarSetDate As Date)
Dim wDate As Date
Dim dayi As Integer
Dim weekNo As Integer
Dim endDay As Integer
With fromCalendar
For dayi = 1 To 42 'ラベルの初期化
.Controls("LBL_DD" & dayi).Caption = ""
.Controls("LBL_DD" & dayi).BackColor = cnsBC_Other
Next
nowCalendarDate = CDate(Year(calendarSetDate) & "/" & Month(calendarSetDate) & "/" & 1) '当月1日
endDay = day(DateAdd("d", -1, DateAdd("m", 1, nowCalendarDate))) '月末日の算出
weekNo = Weekday(nowCalendarDate) - 1 '当月1日の曜日番号に、マイナス1したもの
'前月
For dayi = 1 To weekNo
With .Controls("LBL_DD" & weekNo - dayi + 1)
.Caption = day(nowCalendarDate - dayi) '日を入れる
.BackColor = cnsBC_Other
End With
days(weekNo - dayi + 1) = nowCalendarDate - dayi
Next
'当月
For dayi = 1 To endDay
With .Controls("LBL_DD" & dayi + weekNo)
.Caption = dayi '日を入れる
wDate = CDate(Year(calendarSetDate) & "/" & Month(calendarSetDate) & "/" & dayi)
Select Case Weekday(wDate) - 1
Case 0
.BackColor = cnsBC_Sunday
Case 6
.BackColor = cnsBC_Saturday
Case Else
.BackColor = cnsBC_Month
End Select
'TextBoxの日と同じなら色をつける
If wDate = calendarSetDate Then
.BackColor = cnsBC_Select
End If
End With
days(dayi + weekNo) = wDate
Next dayi
'翌月
wDate = DateAdd("m", 1, nowCalendarDate)
For dayi = endDay + weekNo + 1 To 42
With .Controls("LBL_DD" & dayi)
.Caption = dayi - (endDay + weekNo) '日を入れる
.BackColor = cnsBC_Other
End With
days(dayi) = wDate + (dayi - (endDay + weekNo)) - 1
Next
YM_YEAR_MONTH_re nowCalendarDate '年月ラベル更新
End With
End Sub
Private Sub YM_YEAR_MONTH_re(wDate As Date)
With fromCalendar
.cmbYMevent = False
.LBL_YM.Caption = Year(wDate) & "年" & Format(Month(wDate), "00") & "月"
.CBO_YEAR = Year(wDate) '年を指定
.CBO_MONTH = Month(wDate) '月を指定
.LBL_YM.Visible = True
.cmbYMevent = True
End With
End Sub
'-- イベント処理
Public Sub LblMonthClick(wmonth As Integer) '←(前月)→(翌月
calendarSet DateAdd("m", wmonth, nowCalendarDate)
End Sub
Public Sub LblYMClick() 'yyyy年mm月
fromCalendar.LBL_YM.Visible = False
End Sub
Public Sub CmbYMChange(wDate As Date) 'yyyy年mm月 コンボ
calendarSet wDate
End Sub
Public Sub LblDDClick(i As Integer) '日選択
retarget.Value = days(i)
fromCalendar.Hide
End Sub
#クラスモジュール化
日付選択イベント処理をクラスモジュール化してみます。
1.sheetにはいつもの起動マクロ
変更がないので省略
2.フォームのマクロです。
日クリックイベントをクラスへ移動しました。
変更行は末尾に'class がある行です。
日ラベルのイベント処理は削除しました
Option Explicit
Public cmbYMevent As Boolean
Private Const cnsSyear = 1900 '対応年 はじめ
Private Const cnsEyear = 2100 '対応年 終わり
Private cDateLabel(1 To 42) As New Class1 '日付ラベルイベント 'class
Private Sub UserForm_Initialize() 'Formが開くとき
Dim i As Integer
For i = cnsSyear To cnsEyear
Me.CBO_YEAR.AddItem i
Next i
For i = 1 To 12 '月を登録
Me.CBO_MONTH.AddItem Format(i, "00")
Next i
cmbYMevent = True
' 各日付ラベルイベントクラスの初期化 'class
For i = 1 To 42 'class
Debug.Print "LBL_DD" & i 'class
Call cDateLabel(i).NewClass(Me.Controls("LBL_DD" & i), i) 'class
Next 'class
End Sub
'-- イベント処理
Private Sub LBL_PREV_Click() '←(前月)
CalendarModule.LblMonthClick -1
End Sub
Private Sub LBL_NEXT_Click() '→(翌月)
CalendarModule.LblMonthClick 1
End Sub
Private Sub LBL_YM_Click() 'yyyy年mm月
CalendarModule.LblYMClick
End Sub
Private Sub CBO_YEAR_Change() '年コンボ
If cmbYMevent Then CalendarModule.CmbYMChange CDate(CBO_YEAR.Value & "/" & CBO_MONTH.Value & "/1")
End Sub
'月コンボ
Private Sub CBO_MONTH_Change()
If cmbYMevent Then CalendarModule.CmbYMChange CDate(CBO_YEAR.Value & "/" & CBO_MONTH.Value & "/1")
End Sub
3.標準モジュール
CalendarModule です。変更ありません。
4.今回追加したクラスモジュール
Option Explicit
Public WithEvents Label As MSForms.Label ' 日ラベル
Private g_lngIndex As Integer ' 日ラベルを配列に
'----------
'引数:Arg1 = ラベル(Object)
' Arg2 = 位置INDEX(Long)
Public Sub NewClass(ByVal objLabel As MSForms.Label, ByVal lngIx As Integer)
Set Label = objLabel
g_lngIndex = lngIx
End Sub
'----------
'ラベルのクリックイベント
Private Sub Label_Click()
Call CalendarModule.LblDDClick(g_lngIndex)
End Sub
#選択したセルの下にカレンダー表示
今のままだと、カレンダーが画面の中央に表示なので選択したセルの下に表示をします。
これが結構厄介なようで、
こちらhttp://www.asahi-net.or.jp/~ef2o-inue/download/sub09_020_025.htmlのパクリです。
出来上がりは、今までと見た目かわりません。
選択セル直下にカレンダー表示
オプション機能なのか、画面からはみ出す場合は、選択したセルの直上に表示されます。すごい!!
フォームの表示位置調整は、こちらhttp://www.asahi-net.or.jp/~ef2o-inue/download/sub09_020_025.htmlのパクリです。
なので、ダウンロードして、modCalendar5Rだけが必要だったので、標準モジュールに配置しています。
1.sheetマクロは変更なし
2.フォームマクロも変更なし
3.標準モジュールのCalendarModule
表示位置設定が追加になっています。
Option Explicit
' フォーム上の色指定等の定数
Private Const cnsBC_Select = &HFFCC33 ' 選択日付の背景色
Private Const cnsBC_Other = &HE0E0E0 ' 当月以外の背景色
Private Const cnsBC_Sunday = &HFFDDFF ' 日曜の背景色
Private Const cnsBC_Saturday = &HDDFFDD ' 土曜の背景色
Private Const cnsBC_Month = &HFFFFFF ' 当月土日以外の背景色
Private days(1 To 42) As Date
Private nowCalendarDate As Date ' 現在表示カレンダー日付 常に月初
Private targetDate As Date
Private retarget As Range
'---- form生成
Public Sub open_calendar(target As Range)
Set retarget = target '日クリックの返し先
If (IsDate(target.Value)) Then 'セルデータ取得
targetDate = CDate(target.Value)
Else
targetDate = Date
End If
calendarSet targetDate 'カレンダー作成
'----ユーザーフォーム表示位置--------------------------------------------------------------------
Dim lngLeft As Long ' 横位置
Dim lngTop As Long ' 縦位置
With fromCalendar
Call modCalendar5R.FP_GetFormPosition(target, .Width, .Height, lngLeft, lngTop) ' ユーザーフォーム表示位置取得
' フォーム表示位置の確認
If ((lngLeft <> 0) Or (lngTop <> 0)) Then
' 指定がある場合はマニュアル指定
.StartUpPosition = 0
.Left = lngLeft
.Top = lngTop
Else
' 指定がない場合はスクリーンの中央
.StartUpPosition = 2
End If
End With
'-----------------------------------------------------------------------------------------------
fromCalendar.Show
End Sub
'---- カレンダー作成
Private Sub calendarSet(calendarSetDate As Date)
Dim wDate As Date
Dim dayi As Integer
Dim weekNo As Integer
Dim endDay As Integer
With fromCalendar
For dayi = 1 To 42 'ラベルの初期化
.Controls("LBL_DD" & dayi).Caption = ""
.Controls("LBL_DD" & dayi).BackColor = cnsBC_Other
Next
nowCalendarDate = CDate(Year(calendarSetDate) & "/" & Month(calendarSetDate) & "/" & 1) '当月1日
endDay = day(DateAdd("d", -1, DateAdd("m", 1, nowCalendarDate))) '月末日の算出
weekNo = Weekday(nowCalendarDate) - 1 '当月1日の曜日番号に、マイナス1したもの
'前月
For dayi = 1 To weekNo
With .Controls("LBL_DD" & weekNo - dayi + 1)
.Caption = day(nowCalendarDate - dayi) '日を入れる
.BackColor = cnsBC_Other
End With
days(weekNo - dayi + 1) = nowCalendarDate - dayi
Next
'当月
For dayi = 1 To endDay
With .Controls("LBL_DD" & dayi + weekNo)
.Caption = dayi '日を入れる
wDate = CDate(Year(calendarSetDate) & "/" & Month(calendarSetDate) & "/" & dayi)
Select Case Weekday(wDate) - 1
Case 0
.BackColor = cnsBC_Sunday
Case 6
.BackColor = cnsBC_Saturday
Case Else
.BackColor = cnsBC_Month
End Select
'TextBoxの日と同じなら色をつける
If wDate = calendarSetDate Then
.BackColor = cnsBC_Select
End If
End With
days(dayi + weekNo) = wDate
Next dayi
'翌月
wDate = DateAdd("m", 1, nowCalendarDate)
For dayi = endDay + weekNo + 1 To 42
With .Controls("LBL_DD" & dayi)
.Caption = dayi - (endDay + weekNo) '日を入れる
.BackColor = cnsBC_Other
End With
days(dayi) = wDate + (dayi - (endDay + weekNo)) - 1
Next
YM_YEAR_MONTH_re nowCalendarDate '年月ラベル更新
End With
End Sub
Private Sub YM_YEAR_MONTH_re(wDate As Date)
With fromCalendar
.cmbYMevent = False
.LBL_YM.Caption = Year(wDate) & "年" & Format(Month(wDate), "00") & "月"
.CBO_YEAR = Year(wDate) '年を指定
.CBO_MONTH = Month(wDate) '月を指定
.LBL_YM.Visible = True
.cmbYMevent = True
End With
End Sub
'-- イベント処理
Public Sub LblMonthClick(wmonth As Integer) '←(前月)→(翌月
calendarSet DateAdd("m", wmonth, nowCalendarDate)
End Sub
Public Sub LblYMClick() 'yyyy年mm月
fromCalendar.LBL_YM.Visible = False
End Sub
Public Sub CmbYMChange(wDate As Date) 'yyyy年mm月 コンボ
calendarSet wDate
End Sub
Public Sub LblDDClick(i As Integer) '日選択
retarget.Value = days(i)
fromCalendar.Hide
End Sub
フォーム表示前に、表示位置をしています。追加したのは、ここです。
'''vba:変更
'----ユーザーフォーム表示位置--------------------------------------------------------------------
Dim lngLeft As Long ' 横位置
Dim lngTop As Long ' 縦位置
With fromCalendar
Call modCalendar5R.FP_GetFormPosition(target, .Width, .Height, lngLeft, lngTop) ' ユーザーフォーム表示位置取得
' フォーム表示位置の確認
If ((lngLeft <> 0) Or (lngTop <> 0)) Then
' 指定がある場合はマニュアル指定
.StartUpPosition = 0
.Left = lngLeft
.Top = lngTop
Else
' 指定がない場合はスクリーンの中央
.StartUpPosition = 2
End If
End With
'-----------------------------------------------------------------------------------------------
### 4.追加した modCalendar5R
基本的に変更しなくても使えるそうですが、modCalendar5R の変更を最小限にするため
239行目 Private Function FP_GetFormPosition(.... を Public にしました。
### 5.クラスモジュールも変更なし
カレンダ奮闘記はこれでおしまい。
[物忘れ防止 calendar_v3_event.xlsm calendar_v4_Class.xlsm calendar_v5.xlsm ](https://github.com/sugita0301/douzo/blob/master/calendar_v3-5_pack.zip)
https://github.com/sugita0301/douzo