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

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

Option Explicit

Const DialogSheetName = "CalendarDialog"

'年と月の変化時のマクロ
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
    
    With ActiveDialog.Labels
        If IsNumeric(obj1.Text) Then
            If obj1.Text <= 100 Then
                .Item(1).Text = ""
                .Item(2).Text = ""
            Else
                .Item(1).Text = Format$(date1, "yyyy/mm/dd")
                .Item(2).Text = Format$(date1, _
                    "yyyy年" & Chr$(10) & Chr$(10) & "ggg e年" & _
                    Chr$(10) & Chr$(10) & "m月 d日(aaa)")
            End If
        Else
            .Item(1).Text = ""
            .Item(2).Text = ""
        End If
    End With

    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
    Dim date1 As Date

    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
    date1 = DateSerial(y, m, d)
    With ActiveDialog.Labels
        If y <= 100 Then
            .Item(1).Text = ""
            .Item(2).Text = ""
        Else
            .Item(1).Text = Format$(date1, "yyyy/mm/dd")
            .Item(2).Text = Format$(date1, _
                "yyyy年" & Chr$(10) & Chr$(10) & "ggg e年" & _
                Chr$(10) & Chr$(10) & "m月 d日(aaa)")
        End If
    End With
    Exit Sub
err_1:
    MsgBox "日付が不正です。", vbExclamation, "日付入力"
End Sub

'スピンボタン変化時のマクロ
Sub Spinner1_Change()
    Dim edit1 As Object
    Dim i As Integer
    Dim s As String
    
    Set edit1 = ActiveDialog.EditBoxes(1)
    s = edit1.Text
    If IsNumeric(s) Then
        i = CInt(s)
    Else
        i = Year(Date)
        edit1.Text = i
    End If

    With ActiveDialog.DrawingObjects(Application.Caller)
        If .Value = 0 Then
             edit1.Text = i + 1
        Else
             edit1.Text = i - 1
        End If
        .Value = 1
        EditBox1_Change
    End With
End Sub

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

'カレンダーダイアログで日付を入力する関数
Function CalendarDialogDate() As Variant
    With ThisWorkbook.DialogSheets(DialogSheetName)
        If .Show Then
            If IsDate(.Labels(1).Text) Then
                CalendarDialogDate = CDate(.Labels(1).Text)
            Else
                CalendarDialogDate = CVErr(xlErrValue)
            End If
        Else
            CalendarDialogDate = False
        End If
    End With
End Function

'カレンダーダイアログのテスト用マクロ
Sub Test()
    Dim v As Variant
    v = CalendarDialogDate
    Select Case VarType(v)
        Case vbBoolean
            MsgBox "キャンセルされました。", vbExclamation, "Calendar Dialog Test"
        Case vbDate
            MsgBox v, , "Calendar Dialog Test"
        Case Else
            MsgBox "日付が不正です。", vbExclamation, "Calendar Dialog Test"
    End Select
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 * 53
            .Height = gw * 31
            .Caption = "日付入力"
            .OnAction = "Form1_Show"
        End With
        .DrawingObjects.Delete
    End With
    With dlg.Labels.Add(Left:=gw * 70, Top:=gw * 4, _
            Width:=gw * 20, Height:=gw * 3)
        .Text = ""
    End With
    With dlg.Labels.Add(Left:=gw * 51, Top:=gw * 17, _
            Width:=gw * 14, Height:=gw * 16)
        .Text = ""
    End With
    With dlg.EditBoxes.Add(Left:=gw * 14, Top:=gw * 8, _
            Width:=gw * 8, Height:=gw * 3)
        .OnAction = "EditBox1_Change"
        .InputType = xlText
        .DisplayVerticalScrollBar = False
        .MultiLine = False
        .PasswordEdit = False
    End With
    With dlg.Spinners.Add(Left:=gw * 22, Top:=gw * 8, _
            Width:=gw * 3, Height:=gw * 3)
        .OnAction = "Spinner1_Change"
        .Max = 2
        .Min = 0
        .SmallChange = 1
        .Value = 1
    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

    With dlg.Buttons.Add(Left:=gw * 55, Top:=gw * 8, _
            Width:=gw * 10, Height:=gw * 3)
        .Caption = "OK"
        .DismissButton = True
        .CancelButton = False
        .DefaultButton = True
    End With
    With dlg.Buttons.Add(Left:=gw * 55, Top:=gw * 12, _
            Width:=gw * 10, Height:=gw * 3)
        .Caption = StrConv("キャンセル", vbNarrow)
        .DismissButton = False
        .CancelButton = True
        .DefaultButton = False
    End With
    With dlg.GroupBoxes.Add(Left:=gw * 50, Top:=gw * 16, _
            Width:=gw * 15, Height:=gw * 18)
        .Caption = ""
    End With
End Sub