目的
Windows 10 Pro x64 + Excel2016 x86 VBA + DTPicker を試してみる
常に DTPicker が使える環境とは限らないので、カレンダー用のフォームを作成する
いや しようと思ったのだけどExcelVBAでカレンダーコントロールを自作するで公開され
ているCalenderForm1.xlsm をベースに使用させていただきます(休日のサポートは未対応)
※日付の表示が0フィルの4/2/2形式じゃないとな と思うのはなぜなんだろう?
CalenderForm1のコードの修正点
・Option Explicit 付きでコンパイルが通る
・setCallBackControl関数で使用可能なように修正
・それに伴い UserForm_Initialize の内容を移動
・細かい部分の修正(コメント含む)
作成手順
・UserFormを1個追加する
・UserFormの上にテキストボックスを1個追加する
・UserFormの上にコマンドボタンを1個追加する
・DLしたCalenderForm1.xlsmよりCalenderFormをフォームにコピーする
・CalenderFormのコードを修正する
サンプルコード
Option Explicit
Private Sub UserForm_Initialize()
'
TextBox1.Text = Date
'
End Sub
Private Sub CommandButton1_Click()
'
Dim strDate As String
'
' 4桁数字/2桁数字/2桁数字 の並びになっているかを
' チェックするのが良いのかどうか 迷うところ
'
' If Trim(TextBox1.Text) Like "19[0-9][0-9]/[0|1][0-2]/[0-3][0-9]" _
' Or Trim(TextBox1.Text) Like "20[0-9][0-9]/[0|1][0-2]/[0-3][0-9]" Then
If Len(Trim(TextBox1.Text)) > 0 Then
If IsDate(TextBox1.Text) Then
strDate = TextBox1.Text
Else
strDate = Date
End If
Else
strDate = Date
End If
'
Call CalenderForm.setCallBackControl(strDate, TextBox1)
Call CalenderForm.Show
'
End Sub
CalenderForm(オリジナルに一部コードを修正したもの)
Option Explicit
Dim clndr_date As Date
Dim outCtrl As Control
'=================================================================
' 機 能 : メインフォームからのパラメータと出力用のTextBox1
'=================================================================
Public Sub setCallBackControl(atxtDate As String, ByVal inRetCtrl As Control)
Dim i As Integer
'
' 引数は Control で宣言する
'
clndr_date = CDate(atxtDate)
Set outCtrl = inRetCtrl
'
' 前後3年分の年を登録
'
For i = -3 To 3
Me.ComboBox1.AddItem CStr((Year(clndr_date)) + i)
Next i
'
' 月を登録
'
For i = 1 To 12
Me.ComboBox2.AddItem CStr(i)
Next i
'
Me.ComboBox1 = Year(clndr_date) '年を指定
Me.ComboBox2 = Month(clndr_date) '月を指定
End Sub
'=================================================================
' 機 能 : 年が変更されたときの処理
'=================================================================
Private Sub ComboBox1_Change()
Call Clndr_set
End Sub
'=================================================================
' 機 能 : 月が変更されたときの処理
'=================================================================
Private Sub ComboBox2_Change()
Call Clndr_set
End Sub
'=================================================================
' 機 能 : カレンダーの作成と表示
'=================================================================
Private Sub Clndr_set()
'
Dim yy As Integer
Dim mm As Integer
Dim i As Integer
Dim n As Integer
Dim endDay As Integer
'
' 年か月どちらか入ってなければ中止
'
If Me.ComboBox1 = "" Or Me.ComboBox2 = "" Then Exit Sub
yy = Me.ComboBox1 '年
mm = Me.ComboBox2 '月
'
' ラベルの初期化
'
For i = 1 To 37
Me("Label" & i).Caption = ""
Me("Label" & i).BackColor = Me.BackColor
Next
'
' その月の1日の曜日番号に、マイナス1したもの
'
n = Weekday(yy & "/" & mm & "/" & 1) - 1
'
' 月末日の算出:次月の開始日 - 1日
'
endDay = Day(DateAdd("d", -1, DateAdd("m", 1, yy & "/" & mm & "/" & "1")))
'
' TextBoxの日と同じなら色をつける
'
For i = 1 To endDay
Me("Label" & i + n).Caption = i '日を入れる
If CDate(yy & "/" & mm & "/" & i) = clndr_date Then Me("Label" & i + n).BackColor = RGB(200, 200, 200)
Next
'
End Sub
'=================================================================
' 機 能 : ひと月戻る
'=================================================================
Private Sub SpinButton1_SpinUp()
'
If Me.ComboBox2 = 1 Then '1月だったら
Me.ComboBox1 = Me.ComboBox1 - 1 '年-1
Me.ComboBox2 = 12 '12月へ
Else
Me.ComboBox2 = Me.ComboBox2 - 1
End If
'
End Sub
'=================================================================
' 機 能 : ひと月進む
'=================================================================
Private Sub SpinButton1_SpinDown()
'
If Me.ComboBox2 = 12 Then '12月だったら
Me.ComboBox1 = Me.ComboBox1 + 1 '年+1
Me.ComboBox2 = 1 '1月へ
Else
Me.ComboBox2 = Me.ComboBox2 + 1
End If
'
End Sub
'=================================================================
' 機 能 : 日付(ラベル)が押下されたときの処理
' : 形式は yyyy/mm/dd(4桁/2桁/2桁) に統一する
'=================================================================
Private Sub LabelClick(ByVal i As Integer)
'
If Len(Me("Label" & i).Caption) = 0 Then
'
' ブランク押下時は引数として渡された日付をコントールにセット
'
outCtrl = Format(clndr_date, "yyyy/mm/dd")
Else
'
' 日付を生成してコントールにセット
'
outCtrl = Me.ComboBox1 & "/" & Right("0" & Me.ComboBox2, 2) & "/" & Right("0" & Me("Label" & i).Caption, 2)
End If
'
Unload Me
End Sub
Private Sub Label1_Click(): Call LabelClick(1): End Sub
Private Sub Label2_Click(): Call LabelClick(2): End Sub
Private Sub Label3_Click(): Call LabelClick(3): End Sub
Private Sub Label4_Click(): Call LabelClick(4): End Sub
Private Sub Label5_Click(): Call LabelClick(5): End Sub
Private Sub Label6_Click(): Call LabelClick(6): End Sub
Private Sub Label7_Click(): Call LabelClick(7): End Sub
Private Sub Label8_Click(): Call LabelClick(8): End Sub
Private Sub Label9_Click(): Call LabelClick(9): End Sub
Private Sub Label10_Click(): Call LabelClick(10): End Sub
Private Sub Label11_Click(): Call LabelClick(11): End Sub
Private Sub Label12_Click(): Call LabelClick(12): End Sub
Private Sub Label13_Click(): Call LabelClick(13): End Sub
Private Sub Label14_Click(): Call LabelClick(14): End Sub
Private Sub Label15_Click(): Call LabelClick(15): End Sub
Private Sub Label16_Click(): Call LabelClick(16): End Sub
Private Sub Label17_Click(): Call LabelClick(17): End Sub
Private Sub Label18_Click(): Call LabelClick(18): End Sub
Private Sub Label19_Click(): Call LabelClick(19): End Sub
Private Sub Label20_Click(): Call LabelClick(20): End Sub
Private Sub Label21_Click(): Call LabelClick(21): End Sub
Private Sub Label22_Click(): Call LabelClick(22): End Sub
Private Sub Label23_Click(): Call LabelClick(23): End Sub
Private Sub Label24_Click(): Call LabelClick(24): End Sub
Private Sub Label25_Click(): Call LabelClick(25): End Sub
Private Sub Label26_Click(): Call LabelClick(26): End Sub
Private Sub Label27_Click(): Call LabelClick(27): End Sub
Private Sub Label28_Click(): Call LabelClick(28): End Sub
Private Sub Label29_Click(): Call LabelClick(29): End Sub
Private Sub Label30_Click(): Call LabelClick(30): End Sub
Private Sub Label31_Click(): Call LabelClick(31): End Sub
Private Sub Label32_Click(): Call LabelClick(32): End Sub
Private Sub Label33_Click(): Call LabelClick(33): End Sub
Private Sub Label34_Click(): Call LabelClick(34): End Sub
Private Sub Label35_Click(): Call LabelClick(35): End Sub
Private Sub Label36_Click(): Call LabelClick(36): End Sub
Private Sub Label37_Click(): Call LabelClick(37): End Sub