ExcelVBAでカレンダーコントロールを自作する

【2020年12月21日更新】

古くなってExcelのバージョンも変わったため更新記事を書きました。
touch-sp.hatenablog.com
こちらを見てください。
過去の投稿はそのまま残しておきます。

【以下はオリジナル記事（2017年1月12日投稿）です。】

簡単にコピペで再現できるようにボタンなどのコントロールの配置やそのプロパティはすべてコードに記述。フォームやモジュールを追加して下記をコピペするだけで完成。

①カレンダーフォーム「Calender」を追加する

Option Explicit

Private Sub UserForm_Initialize()

    'widthとinsidewidthの差は4.5 (5*2+30*7+4.5=224.5)
    Me.Width = 224.5
    Me.Height = 285
    
    Me.Caption = "カレンダー"

End Sub

②標準モジュール「CalenderModule」を追加する

Option Explicit

Public calender_date As String

Function open_calender(ByVal text_date As String) As String
    
    Dim my_date As Date
    If (IsDate(text_date)) Then
        my_date = CDate(text_date)
    Else
        my_date = Date
    End If
    
    calender_date = text_date
    
    Load Calender
    
    Dim NewBtn(1 To 42) As Object
    Dim NewTxt As Object
    Dim NewCombo As Object
    Dim NewSpin As Object
    
    Dim days_label(0 To 6) As Object
    Dim obj1 As Object
    Dim obj2 As Object
    Dim obj3 As Object
    
    With Calender
        Set obj1 = .Controls.Add("Forms.Label.1", "year_label")
        Set obj2 = .Controls.Add("Forms.Label.1", "month_label")
        Set obj3 = .Controls.Add("Forms.Label.1", "year_month_label")
        
        With obj1
            .Height = 12
            .Width = 12
            .Font.Size = 12
            .Caption = "年"
            .Top = 21
            .Left = 90
        End With
        
        With obj2
            .Height = 12
            .Width = 12
            .Font.Size = 12
            .Caption = "月"
            .Top = 21
            .Left = 170
        End With
        
        With obj3
            .Height = 21
            .Width = 210
            .Font.Size = 16
            .Top = 55
            .Left = 5
            .SpecialEffect = fmSpecialEffectEtched
            .BackColor = RGB(255, 255, 255)
            .TextAlign = fmTextAlignCenter
        End With
        
        Dim i As Integer
        For i = 1 To 42
            Set NewBtn(i) = New ControlSetting
            Set NewBtn(i).myButton = .Controls.Add("Forms.CommandButton.1", "button" & i)
            With NewBtn(i).myButton
                .Height = 25
                .Width = 30
                .Top = 105 + ((i - 1) \ 7) * 25
                .Left = 5 + ((i - 1) Mod 7) * 30
                If (i - 1) Mod 7 = 0 Then .ForeColor = RGB(255, 0, 0)
                If (i - 1) Mod 7 = 6 Then .ForeColor = RGB(0, 0, 255)
            End With
        Next i
        
        Dim days As String
        days = "日月火水木金土"
        Dim days_i As Integer
        For days_i = 0 To 6
            Set days_label(days_i) = .Controls.Add("Forms.Label.1", "days_label" & days_i)
            With days_label(days_i)
                .Height = 18
                .Width = 30
                .Top = 87
                .Left = 5 + days_i * 30
                .Font.Size = 14
                .Font.Bold = True
                .TextAlign = fmTextAlignCenter
                .Caption = Mid(days, days_i + 1, 1)
                If days_i = 0 Then .ForeColor = RGB(255, 0, 0)
                If days_i = 6 Then .ForeColor = RGB(0, 0, 255)
            End With
        Next days_i
        
        Set NewTxt = New ControlSetting
        Set NewTxt.myTxt = .Controls.Add("Forms.TextBox.1", "year_txt")
        With NewTxt.myTxt
           .Height = 18
           .Width = 66
           .Top = 18
           .Left = 15
           .Font.Size = 12
           .TextAlign = fmTextAlignCenter
           .IMEMode = fmIMEModeDisable
           .Text = Year(my_date)
        End With
        
        Set NewCombo = New ControlSetting
        Set NewCombo.myCombo = .Controls.Add("Forms.ComboBox.1", "month_txt")
        With NewCombo.myCombo
            .Height = 18
            .Width = 48
            .Top = 18
            .Left = 115
            .Font.Size = 12
            .TextAlign = fmTextAlignCenter
            .Style = fmStyleDropDownCombo
            .ListRows = 12
             Dim month_i As Integer
             For month_i = 1 To 12
                 .AddItem month_i
             Next month_i
            .ListIndex = Month(my_date) - 1
        End With
         
        Set NewSpin = New ControlSetting
        Set NewSpin.mySpin = .Controls.Add("Forms.SpinButton.1", "updown")
        With NewSpin.mySpin
            .Height = 25.5
            .Width = 12.75
            .Top = 14
            .Left = 190
        End With
            
    End With
    
    Dim num As Integer
    Dim dd As String
    dd = Day(my_date)
    For num = 1 To 42
        If Calender.Controls("button" & num).Caption = dd And Calender.Controls("button" & num).Enabled Then
            Calender.Controls("button" & num).SetFocus
        End If
    Next num
    
    Calender.Show
    
    open_calender = calender_date
    
End Function
Function calender_hantei() As Boolean

    Dim kekka As Boolean
    
    If Not IsNumeric(Calender.Controls("year_txt").Text) Then
        kekka = False
    Else
        Calender.Controls("year_txt").Text = Int(Calender.Controls("year_txt").Text)
        kekka = True
    End If
    
    calender_hantei = kekka
  
End Function

Function calender_reload()

    Dim yy As Integer
    yy = Calender.Controls("year_txt").Text
    
    If yy < 1800 Then Exit Function
    If yy > 3000 Then Exit Function
    
    Dim button_i As Integer
    For button_i = 1 To 42
        Calender.Controls("button" & button_i).Caption = ""
        Calender.Controls("button" & button_i).Font.Size = 10
        Calender.Controls("button" & button_i).Enabled = False
    Next button_i
    
    Dim mm As Integer
    Dim d As Date
    Dim start_position As Integer
    Dim end_day As Integer
    
    yy = Calender.Controls("year_txt").Text
    mm = Calender.Controls("month_txt").Text
    Calender.Controls("year_month_label").Caption = yy & "年" & mm & "月"
    
    d = yy & "/" & mm & "/" & 1
    start_position = Weekday(d)

    Dim days_number As Integer '何日あるか
    days_number = Day(DateSerial(yy, mm + 1, 0))
    
    Dim start_day As Date
    start_day = d - (start_position - 1)
    Dim index As Integer
    For index = 1 To 42
        Calender.Controls("button" & index).Caption = Day(start_day + index - 1)
        If Month(start_day + index - 1) = mm Then
            Calender.Controls("button" & index).Font.Size = 12
            Calender.Controls("button" & index).Enabled = True
        End If
    Next index
        
End Function

③クラスモジュール「ControlSetting」を追加する

Option Explicit

Public WithEvents myButton As CommandButton
Public WithEvents myTxt As MSForms.TextBox
Public WithEvents myCombo As MSForms.ComboBox
Public WithEvents mySpin As MSForms.SpinButton

Private Sub myButton_Click()

    calender_date = Calender.Controls("year_month_label").Caption & myButton.Caption & "日"

    Unload Calender    

End Sub

Private Sub myTxt_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
     
    If KeyCode = vbKeyReturn Then
        Dim hantei As Boolean
        hantei = calender_hantei
        If Not (hantei) Then Exit Sub
        
        Call calender_reload
    End If

End Sub

Private Sub myCombo_Change()
    
    If Not (Me.myCombo.MatchFound) Then Exit Sub
    
    Dim hantei As Boolean
    hantei = calender_hantei
    If Not (hantei) Then Exit Sub
    
    Call calender_reload
    
End Sub

Private Sub mySpin_SpinDown()
    
    Dim hantei As Boolean
    hantei = calender_hantei
    If Not (hantei) Then Exit Sub
    
    Dim index As String
    index = Calender.Controls("month_txt").ListIndex
    If (index = -1) Then Exit Sub
    If (index = 0) Then
        Calender.Controls("year_txt").Text = Calender.Controls("year_txt").Text - 1
        index = 11
    Else
        index = index - 1
    End If
    Calender.Controls("month_txt").ListIndex = index
    
End Sub

Private Sub mySpin_SpinUp()

    Dim hantei As Boolean
    hantei = calender_hantei
    If Not (hantei) Then Exit Sub
    
    Dim index As String
    index = Calender.Controls("month_txt").ListIndex
    If (index = 11) Then
        Calender.Controls("year_txt").Text = Calender.Controls("year_txt").Text + 1
        index = 0
    Else
        index = index + 1
    End If
    Calender.Controls("month_txt").ListIndex = index
    
End Sub

使い方は、例としてテキストボックス「TextBox1」とコマンドボタン「CommandButton1」がセットされているユーザーフォームで

Private Sub CommandButton1_Click()

    TextBox1.Text = open_calender(TextBox1.Text)
    
End Sub