'カレンダーダイアログボックス

'MakeDialogマクロを実行してダイアログシートを作成し、
'Testマクロを実行してください。

Option Explicit

Const DialogSheetName = "CalendarDialog"

Dim CalendarDate As Date

'年と月の変化時のマクロ
Sub EditBox1_Change()
    Dim obj1 As Object, obj2 As Object
    Dim s As String
    Dim date1 As Date, date2 As Date
    Dim i As Integer, m As Integer

    On Error GoTo err_1
    Application.ScreenUpdating = False

    Set obj1 = ActiveDialog.EditBoxes(1)
    Set obj2 = ActiveDialog.DropDowns(1)

    If obj1.Text = "" Then obj1.Text = Year(Date)
    If obj2.ListIndex = 0 Then obj2.ListIndex = Month(Date)
    m = obj2.ListIndex

    s = obj1.Text & "/" & m & "/1"
    If IsDate(s) Then
        date1 = DateValue(s)
    Else
        obj1.Text = Year(Date)
        date1 = DateSerial(Year(Date), obj2.ListIndex, 1)
    End If

    date1 = date1 - WeekDay(date1)

    With ActiveDialog.TextBoxes
        For i = 1 To 42
            date2 = date1 + i
            With .Item(i)
                .Text = Day(date2)
                If Month(date2) = m Then
                    With .Font
                        .Bold = True
                        .Italic = False
                    End With
                Else
                    With .Font
                        .Bold = False
                        .Italic = True
                    End With
                End If
            End With
        Next
    End With
    Application.ScreenUpdating = True
    Exit Sub
err_1:
    MsgBox "日付が不正です。", vbExclamation, "日付入力"
End Sub

'日付テキストボックスクリック時のマクロ
Sub TextBoxes_Click()
    Dim y As Integer, m As Integer, d As Integer
    Dim i As Integer

    On Error GoTo err_1
    With ActiveDialog
        With .TextBoxes(Application.Caller)
            i = .Index
            d = CInt(.Text)
        End With
        y = CInt(.EditBoxes(1).Text)
        m = .DropDowns(1).ListIndex
    End With

    If d > i Then
        m = m - 1
    ElseIf d < i - 6 Then
        m = m + 1
    End If
    CalendarDate = DateSerial(y, m, d)
    ActiveDialog.Hide
    Exit Sub
err_1:
    MsgBox "日付が不正です。", vbExclamation, "日付入力"
End Sub

'ダイアログ表示時のマクロ
Sub Form1_Show()
    EditBox1_Change
End Sub


'カレンダーダイアログのテスト用マクロ
Sub Test()
    If ThisWorkbook.DialogSheets(DialogSheetName).Show Then
        MsgBox CalendarDate
    End If
End Sub


'カレンダーダイアログを作成するマクロ
Sub MakeDialog()
    Dim dlg As DialogSheet
    Dim gw As Double
    Dim i As Integer, j As Integer, k As Integer
    Application.ScreenUpdating = False
    Set dlg = DialogSheets.Add
    With dlg
        .Name = DialogSheetName
        gw = .Buttons(1).Height / 3
        With .DialogFrame
            .Left = gw * 13
            .Top = gw * 4
            .Width = gw * 37
            .Height = gw * 31
            .Caption = "日付入力"
            .OnAction = "Form1_Show"
        End With
        .DrawingObjects.Delete
    End With
    With dlg.EditBoxes.Add(Left:=gw * 14, Top:=gw * 8, _
            Width:=gw * 11, Height:=gw * 3)
        .OnAction = "EditBox1_Change"
        .InputType = xlText
        .DisplayVerticalScrollBar = False
        .MultiLine = False
        .PasswordEdit = False
    End With
    With dlg.Labels.Add(Left:=gw * 25, Top:=gw * 8, _
            Width:=gw * 5, Height:=gw * 3)
        .Caption = "年"
    End With
    With dlg.DropDowns.Add(Left:=gw * 31, Top:=gw * 8, _
            Width:=gw * 10, Height:=gw * 3)
        .OnAction = "EditBox1_Change"
        .DropDownLines = 12
        .List = Array("1月", "2月", "3月", "4月", "5月", "6月", _
            "7月", "8月", "9月", "10月", "11月", "12月")
    End With

    For k = 1 To 42
        dlg.TextBoxes.Add 1, 1, 1, 1
    Next
    k = 1
    For i = 0 To 5
        For j = 0 To 6
            With dlg.TextBoxes(k)
                .Left = gw * 14 + gw * 5 * j
                .Top = gw * 16 + gw * 3 * i
                .Width = gw * 5
                .Height = gw * 3
            End With
            k = k + 1
        Next
    Next
    With ActiveSheet.TextBoxes
        .OnAction = "TextBoxes_Click"
        With .Border
            .LineStyle = xlContinuous
            .ColorIndex = 15
            .Weight = xlHairline
        End With
    End With

    For k = 1 To 7
        dlg.TextBoxes.Add 1, 1, 1, 1
    Next

    k = 43
    For j = 0 To 6
        With dlg.TextBoxes(k)
            .Left = gw * 14 + gw * 5 * j
            .Top = gw * 13
            .Width = gw * 5
            .Height = gw * 3
            .Text = Mid$("日月火水木金土", j + 1, 1)
            .Border.LineStyle = xlNone
            .Interior.ColorIndex = xlNone
        End With
        k = k + 1
    Next

    With ActiveSheet.TextBoxes
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        For i = 1 To 49 Step 7
            .Item(i).Font.ColorIndex = 3
        Next
        For i = 7 To 49 Step 7
            .Item(i).Font.ColorIndex = 5
        Next
    End With
End Sub