Excelマクロ（日付選択）

Sheet1.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Sheet1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Public Sub Button1_Click()
    Call CalForm.SetSelectDate(Range("A1").Value)
    CalForm.Show
    If Not CalForm.Cancel Then
        Range("A1").Value = Format(CalForm.SelectDate, "yyyy/mm/dd")
    End If
    Unload CalForm
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Address(False, False) = "A2" Then
        Call CalForm.SetSelectDate(Range("A2").Value)
        CalForm.Show
        If Not CalForm.Cancel Then
            Range("A2").Value = Format(CalForm.SelectDate, "yyyy/mm/dd")
        End If
        Unload CalForm
    End If
End Sub

```CalForm.frm
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CalForm 
   Caption         =   "日付選択"
   ClientHeight    =   3615
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4455
   OleObjectBlob   =   "CalForm.frx":0000
   StartUpPosition =   1  'オーナー フォームの中央
End
Attribute VB_Name = "CalForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Const LIMITMINDATE As Date = #3/1/1900#
Private Const LIMITMAXDATE As Date = #12/31/9999#

Private WithEvents CalLabel As ArrayLabelHandler
Attribute CalLabel.VB_VarHelpID = -1
Private BaseDate As Date
Private LoadForm As Boolean

Private mySelectDate As Date
Private myCancel As Boolean

Public Property Get SelectDate() As Date
    SelectDate = mySelectDate
End Property

Public Property Get Cancel() As Boolean
    Cancel = myCancel
End Property

Public Sub SetSelectDate(SelectDate As String)
    LoadForm = False

    If IsDate(SelectDate) Then
        mySelectDate = CDate(SelectDate)
    End If

    If mySelectDate < LIMITMINDATE Then
        mySelectDate = Date
    End If

    Call SetComboboxValue(ComboBoxMonth, Month(mySelectDate))
    Call SetComboboxValue(ComboBoxYear, Year(mySelectDate))
    Call MakeCalendar

    myCancel = False
    LoadForm = True
End Sub

Private Sub UserForm_Initialize()
    Dim i As Integer

    Set CalLabel = New ArrayLabelHandler
    With CalLabel
        For i = 1 To 42
            .Add Me.Controls("Label" & i)
        Next i
        .Regist
    End With

    With ComboBoxMonth
        For i = 1 To 12
            .AddItem i
        Next i
    End With

    With ComboBoxYear
        For i = 1900 To 9999
            .AddItem i
        Next i
    End With

    LoadForm = True
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call CommandButtonCancel_Click

    If CloseMode = vbFormControlMenu Then
        Cancel = True
    End If
End Sub

Private Sub UserForm_Terminate()
    CalLabel.Clear
    Set CalLabel = Nothing
End Sub

Private Sub ComboBoxMonth_Change()
    LabelMonth.Caption = ComboBoxMonth.Value

    If LoadForm = False Then
        Exit Sub
    End If

    Call MakeCalendar
End Sub

Private Sub ComboBoxYear_Change()
    LabelYear.Caption = ComboBoxYear.Value

    If LoadForm = False Then
        Exit Sub
    End If

    Call MakeCalendar
End Sub

Private Sub calLabel_Click(ByVal Index As Integer)
    If CalLabel.Item(Index).Item.Caption = vbNullString Then
        Exit Sub
    End If

    Dim WorkDate As Date
    WorkDate = BaseDate + (Index - 1)
    If WorkDate < LIMITMINDATE Then
        Exit Sub
    End If

    mySelectDate = WorkDate
    Me.Hide
End Sub

Private Sub CommandButtonCancel_Click()
    myCancel = True
    Me.Hide
End Sub

Private Sub MakeCalendar()
    Dim FirstDate As Date
    Dim LastDate As Date
    Dim WorkDate As Date
    Dim LimitOver As Boolean
    Dim Offset As Integer
    Dim i As Integer

    FirstDate = DateSerial(ComboBoxYear.Value, ComboBoxMonth.Value, 1)

    If Format(FirstDate, "yyyymm") = Format(LIMITMAXDATE, "yyyymm") Then
        LastDate = LIMITMAXDATE
    Else
        LastDate = DateSerial(ComboBoxYear.Value, ComboBoxMonth.Value + 1, 0)
    End If

    BaseDate = (FirstDate - Weekday(FirstDate)) + 1

    Offset = 0
    For i = CalLabel.MinIndex To CalLabel.MaxIndex
        With CalLabel.Item(i).Item
            If Not LimitOver Then
                WorkDate = BaseDate + Offset
                .Caption = Day(WorkDate)
            Else
                WorkDate = LIMITMINDATE
                .Caption = ""
            End If

            If WorkDate < FirstDate Or WorkDate > LastDate Then
                .BackColor = vbButtonFace
                .ForeColor = vbGrayText
                .SpecialEffect = fmSpecialEffectFlat
                .BorderStyle = fmBorderStyleSingle
            Else
                If WorkDate = mySelectDate Then
                    .BackColor = vbButtonShadow
                    .ForeColor = vbButtonText
                    .SpecialEffect = fmSpecialEffectSunken
                    .BorderStyle = fmBorderStyleNone
                Else
                    .BackColor = vbButtonFace
                    .ForeColor = vbHighlight
                    .SpecialEffect = fmSpecialEffectFlat
                    .BorderStyle = fmBorderStyleSingle
                End If
            End If
        End With

        If WorkDate >= LIMITMAXDATE Then
            LimitOver = True
        End If

        Offset = Offset + 1
    Next i
End Sub

Private Sub SetComboboxValue(ByVal Combbox As MSForms.ComboBox, ByVal Value)
    With Combbox
        .Style = fmStyleDropDownCombo
        .Value = Value
        .Style = fmStyleDropDownList
    End With
End Sub

ArrayLabelHandler.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ArrayLabelHandler"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Event Click(ByVal Index As Integer)

Private myItem() As ArrayLabel
Private myLabels As Collection

Private Sub Class_Initialize()
    Set myLabels = New Collection
End Sub

Public Sub Add(ByVal Label As MSForms.Label)
    myLabels.Add Label
End Sub

Public Sub Regist()
    Dim i As Integer
    ReDim myItem(1 To myLabels.Count)
    For i = 1 To myLabels.Count
        Set myItem(i) = New ArrayLabel
        With Item(i)
            .Item = myLabels(i)
            .Index = i
            .Handler = Me
        End With
    Next i
End Sub

Public Sub Clear()
    Dim i As Integer
    For i = LBound(myItem) To UBound(myItem)
        myItem(i).Clear
    Next i
    Erase myItem
    Set myLabels = Nothing
End Sub

Public Property Get MinIndex() As Integer
    MinIndex = LBound(myItem)
End Property

Public Property Get MaxIndex() As Integer
    MaxIndex = UBound(myItem)
End Property

Public Property Get Item(ByVal Index As Integer) As ArrayLabel
    Set Item = myItem(Index)
End Property

Public Sub RaiseClick(ByVal Index As Integer)
    RaiseEvent Click(Index)
End Sub

ArrayLabel.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ArrayLabel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private WithEvents myItem As MSForms.Label
Attribute myItem.VB_VarHelpID = -1
Private myIndex As Integer
Private myHandler As ArrayLabelHandler

Public Sub Clear()
    Set myItem = Nothing
    Set myHandler = Nothing
End Sub

Public Property Let Item(Item As MSForms.Label)
    Set myItem = Item
End Property

Public Property Get Item() As MSForms.Label
    Set Item = myItem
End Property

Public Property Let Index(Index As Integer)
    myIndex = Index
End Property

Public Property Let Handler(Handler As ArrayLabelHandler)
    Set myHandler = Handler
End Property

Private Sub myItem_Click()
    myHandler.RaiseClick myIndex
End Sub