- ホーム
- etc
- Simple calender
Simple calender
シンプルなカレンダーのフォームを表示して、日付を選択入力できるツールです。
土日に色を付けて判別できる様にする機能しかありません。
コントロールを配列化していますが、「疑似からの脱却」を行う事で、使いやすくしています。
日付を表示するlabelのクラスからは呼び元の関数を実行できるだけ（With Eventでクラスの配列を使えない）なので、
いまいち使いにくかったのですが、参考サイトの考え方の導入で呼び元のコードがすっきりします。親クラスをUserFormにするのに
少々悩みました。
http://www.h3.dion.ne.jp/~sakatsu/Breakthrough_P-Ctrl_Arrays10.htm
本家に立派なカレンダーが載っていますが、そちらとは無関係で、触ってみておりません。
作業用ワークシートつかいまくりの、数年前に作成したものを手直して作業用シート不要にしたものです。
☆Sheet Moduleに記述
'====================================================================
'simpleCalenderFormはUserFormの名前です
Private WithEvents myform As simpleCalenderForm
Private Sub myform_dateSelect(selectedDate As Date)
ActiveCell.Value = selectedDate
Unload myform
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Me.Columns(1)) Is Nothing Then
simpleCalenderForm.Show vbModeless
Set myform = simpleCalenderForm
End If
End Sub
☆simpleCalenderFormのForm Moduleに記述
'====================================================================
'UserFormには、ComboBox2個を設置しておきます。Labelは動的に設置します。
Public Event dateSelect(selectedDate As Date)
Dim myClsIndex As Integer 'ラベルコントロールの番号
Dim labelArray() As LabelCtrl 'ラベルコントロールの配列
Dim currentMonth As Long
Dim currentYear As Long
'Dim myCaller As Object
Dim myDate As Date
'カレンダーフォームのための定数
Const yOffset As Integer = 16 'フォーム上の、コンボボックス分のoffset
Const labelWidth As Integer = 12
Const labelHeight As Integer = 12
Const dataNum As Integer = 31 '31日/月
Const weekdays As Integer = 7
Private Sub UserForm_Initialize()
Dim i As Integer
Dim myMonth As Integer
Dim myYear As Integer
Dim etchingLines() As String
myClsIndex = 0
'ユーザーフォームの設定
With Me
.caption = "日付選択"
.Width = (labelWidth + 2) * weekdays + 10
.Height = (labelHeight + 2) * 7 + yOffset + 2
.BackColor = RGB(255, 255, 255)
End With
'コンボボックスの設定
myYear = year(Date)
'当日の年を設定 過去2年分まで選択可
currentYear = myYear
With Me.ComboYear
.AddItem Format(myYear, "####")
.AddItem Format(myYear - 1, "####")
.AddItem Format(myYear - 2, "####")
.Value = Format(myYear, "####")
End With
'当日の月を設定
currentMonth = Month(Date)
With Me.ComboMonth
For myMonth = 1 To 12
.AddItem Format(myMonth, "#")
Next myMonth
.Value = Format(Month(Date), "#")
End With
'ラベルコントロールの配列生成
For i = 1 To dataNum
Call addLabel(Format(i, "#"))
Next i
'ラベルコントロールの配列の初期設定
Call setLabels
kFormPosCell Me
End Sub
'ラベルコントロール配列のクリックイベントで起動されるルーチン
Public Sub labelClicked(clickItemNo As Integer)
myDate = DateValue(CStr(currentYear) & "/" & CStr(currentMonth) & "/" & CStr(clickItemNo))
RaiseEvent dateSelect(myDate)
' Me.Hide
End Sub
'ラベルコントロール配列のプロパティ設定
Sub setLabels()
Dim i As Integer
'Userform上のラベルの列・行を指している
Dim columnNo As Long
Dim rowNo As Long
Dim dateTable As Range
Dim labelTop As Long
Dim labelLeft As Long
Dim textColor As String
Dim strDate As String
'日付、曜日等の入った範囲を指定
columnNo = 1
rowNo = 1
For i = 1 To dataNum
'日付関数のエラーを利用することで、カレンダー上
'あり得ない日を表示しない様にしている
strDate = CStr(currentYear) & "/" & CStr(currentMonth) & "/" & CStr(i)
If dateCheck(strDate) Then
columnNo = Weekday(DateValue(strDate))
labelLeft = 3 + (columnNo - 1) * (labelWidth + 2)
labelTop = yOffset + (rowNo - 1) * (labelHeight + 2)
Select Case columnNo
Case 1
textColor = "Red"
Case 7
textColor = "Blue"
Case Else
textColor = "Black" '実際は使っていない
End Select
With labelArray(i)
.left = labelLeft
.top = labelTop
.visible = True
.textColor = textColor
End With
'土曜日の次は行を改める
If columnNo = 7 Then rowNo = rowNo + 1
Else
labelArray(i).visible = False
End If
Next i
End Sub
'ラベルの追加
Private Function addLabel(caption As String) As Integer
Dim myLabel As MSForms.Label
Set myLabel = Me.Controls.Add("Forms.Label.1", , False)
myClsIndex = myClsIndex + 1
With myLabel
.caption = caption
.Height = labelHeight
.Width = labelWidth
.BackColor = RGB(255, 255, 255)
.TextAlign = fmTextAlignRight
End With
ReDim Preserve labelArray(1 To myClsIndex)
Set labelArray(myClsIndex) = New LabelCtrl
Set labelArray(myClsIndex).parent = Me
labelArray(myClsIndex).S_SetLabel myLabel, myClsIndex
End Function
Private Sub ComboMonth_Change()
currentMonth = ComboMonth.Value
'この辺は過去の名残で必要性？
If Me.visible Then
'ラベルの再設定
Call setLabels
End If
End Sub
Private Sub ComboYear_Change()
currentYear = ComboYear.Value
If Me.visible Then
Call setLabels
End If
End Sub
'カレンダー上正しい日付かチェックする関数
Private Function dateCheck(strDate As String) As Boolean
Dim dummyDate As Date
On Error GoTo errHandle
dummyDate = DateValue(strDate)
errHandle:
If Err.Number <> 0 Then
dateCheck = False
Else
dateCheck = True
End If
End Function
'kFormPosCell関数
'http://www2.aqua-r.tepm.jp/~kmado/ke_m11.htm
'ユーザーフォームを指定セルに表示
'uf：ユーザーフォーム
'pos：表示するセル位置(既定値はActiveCellの右下)
Sub kFormPosCell(uf As Object, Optional pos As Range)
'中味は参考サイトをご参照下さい。
End Sub
☆Class Module: LabelCtrl
'====================================================================
Private WithEvents myLabel As MSForms.Label
Private myIndex As Integer
Private myParent As Object 'simpleCalenderForm
Public Sub S_SetLabel(newLabel As MSForms.Label, index As Integer)
Set myLabel = newLabel
myIndex = index
End Sub
Private Sub myLabel_Click()
Call Me.parent.labelClicked(myIndex)
End Sub
Public Property Get top() As Integer
top = myLabel.top
End Property
Public Property Let top(myNewTop As Integer)
myLabel.top = myNewTop
End Property
Public Property Get left() As Integer
left = myLabel.left
End Property
Public Property Let left(myNewleft As Integer)
myLabel.left = myNewleft
End Property
Public Property Let visible(myNewVisible As Boolean)
If myNewVisible Then
myLabel.visible = True
Else
myLabel.visible = False
End If
End Property
Public Property Let textColor(myNewTextColor As String)
With myLabel
Select Case myNewTextColor
Case "Red"
.ForeColor = &HFF&
Case "Blue"
.ForeColor = &HFF0000
Case Else
.ForeColor = &H0&
End Select
End With
End Property
Public Property Get parent() As Object 'simpleCalenderForm
Set parent = myParent
End Property
Public Property Set parent(newParent As Object)
Set myParent = newParent
End Property