1
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 5 years have passed since last update.

Windows 10 Pro x64 + Excel2016 x86 VBA で CalenderForm を試してみる

Last updated at Posted at 2019-02-08

目的

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
1
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
1
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?