search

vieyahn2017 / iBlog

44 stars 0 forks source link

9.9 VBA自己写的日期时间选择控件 #364

Closed vieyahn2017 closed 3 months ago

vieyahn2017 commented 3 years ago

网上的帖子都说在VB/VBA中添加控件,选择Microsoft Date and Time Picker，就可以。但是这个控件excel并没有自带。

这边在网上找了一份网友写的代码，该代码只有日期选择功能。

然后我增加了时间选择的功能

vieyahn2017 commented 3 years ago

【图略】

vieyahn2017 commented 3 years ago

类模块 DateControl


Option Explicit

Private WithEvents conLabel As MSForms.Label
Private WithEvents conComboBox As MSForms.ComboBox
Private WithEvents conCommandButton As MSForms.CommandButton

Property Get myDate() As Date
    With UsFormDateControl
        myDate = CDate(.Caption)
    End With
End Property

Public Sub ReceiveLabel(ByVal reLabel As MSForms.Label)
    Set conLabel = reLabel
End Sub

Public Sub ReceiveComboBox(ByVal reComboBox As MSForms.ComboBox)
    Set conComboBox = reComboBox
End Sub

Public Sub ReceiveCommandButton(ByVal reCommandButton As MSForms.CommandButton)
    Set conCommandButton = reCommandButton
End Sub

Private Sub conComboBox_Change()
    ' 我新加的更改时间的代码
    If InStr(conComboBox.Name, "DatetimeComboBox") Then
        setCaption (myDate())

        If typeName(Selection) = "Range" Then
            Selection = UsFormDateControl.Caption
        End If

        Exit Sub
    End If

    ' 原有的更改年月的代码
    With UsFormDateControl
        .AddLabel_Day DateSerial(.Controls("ComboBoxYear"), .Controls("ComboBoxMonth"), Day(.Caption)), False
    End With

    If typeName(Selection) = "Range" Then
            Selection = UsFormDateControl.Caption
    End If
End Sub

Private Sub conCommandButton_Click()
    Dim iTmp As Integer
    With UsFormDateControl
        Select Case conCommandButton.Name
            Case "Year-"
                iTmp = .Controls("ComboBoxYear").Value
                If iTmp <> 1900 Then .Controls("ComboBoxYear").Value = iTmp - 1
            Case "Year+"
                iTmp = .Controls("ComboBoxYear").Value
                If iTmp <> 2999 Then .Controls("ComboBoxYear").Value = iTmp + 1
            Case "Month-"
                iTmp = .Controls("ComboBoxMonth").Value
                .Controls("ComboBoxMonth").Value = IIf(iTmp - 1 Mod 12, iTmp - 1, 12)
            Case "Month+"
                iTmp = .Controls("ComboBoxMonth").Value
                .Controls("ComboBoxMonth").Value = IIf(iTmp Mod 12, iTmp + 1, 1)
        End Select
    End With
End Sub

Private Sub conLabel_Click()
    Dim sTmp As String

    With UsFormDateControl

        setCaption (CDate(Replace(conLabel.Name, "LabelDay", "")))

        sTmp = .sLabelName

        conLabel.BackColor = RGB(0, 100, 250)
        If sTmp <> conLabel.Name And Len(sTmp) > 0 Then
            On Error Resume Next
            .Controls(sTmp).BackColor = RGB(230, 230, 230)
            On Error GoTo 0
        End If
        .sLabelName = conLabel.Name

        '如果选中其他月份的标签，重置日期。
        If Month(.Caption) <> Val(.Controls("ComboBoxMonth").Value) Then
            .AddLabel_Day myDate, False
            .Controls("ComboBoxMonth").Value = Month(.Caption)
        End If
    End With

    If typeName(Selection) = "Range" Then
        Selection = UsFormDateControl.Caption
    End If

    'Unload UsFormDateControl
End Sub

Public Sub setCaption(ByVal myDate As Date)

    Dim cHour As String
    Dim cMinute As String
    Dim cSecond As String

    With UsFormDateControl
        cHour = .Controls("DatetimeComboBoxHour").Value
        cMinute = .Controls("DatetimeComboBoxMinute").Value
        cSecond = .Controls("DatetimeComboBoxSecond").Value

        '设置窗体的Caption
        .Caption = Format(myDate, "yyyy/mm/dd") & " " & cHour & ":" & cMinute & ":" & cSecond

    End With

End Sub
vieyahn2017 commented 3 years ago

窗体

Option Explicit

Private clsDC As New DateControl
Private co As New Collection
Public sLabelName As String

'窗体加载
Private Sub UserForm_Initialize()
    With Me
        .width = 214
    End With
    AddHead Date
    AddLabel_Week
    AddLabel_Day Date, True
    Me.Controls("ComboBoxYear").SetFocus
End Sub

'添加 头部控件
Private Sub AddHead(ByVal myDate As Date)
    Dim i As Integer
    Dim conCommandButton As MSForms.CommandButton
    Dim conComboBox As MSForms.ComboBox

    '添加 年列表 左按钮
    Set conCommandButton = Me.Controls.Add("Forms.CommandButton.1", "Year-")
    With conCommandButton
        .width = 25
        .Height = 18
        .Caption = "<<<"
    End With
    clsDC.ReceiveCommandButton conCommandButton
    co.Add clsDC
    Set clsDC = Nothing

    '添加 年列表
    Set conComboBox = Me.Controls.Add("Forms.ComboBox.1", "ComboBoxYear")
    With conComboBox
        For i = 1900 To 2100
            .AddItem i
        Next
        .Left = 25
        .width = 60
        .Height = 18
        .Value = Year(myDate)
        .Font.Size = 12
        .ListWidth = 60
        .ColumnWidths = 18
        .Style = fmStyleDropDownList
    End With
    clsDC.ReceiveComboBox conComboBox
    co.Add clsDC
    Set clsDC = Nothing

    '添加 年列表 右按钮
    Set conCommandButton = Me.Controls.Add("Forms.CommandButton.1", "Year+")
    With conCommandButton
        .Left = 85
        .width = 25
        .Height = 18
        .Caption = ">>>"
    End With
    clsDC.ReceiveCommandButton conCommandButton
    co.Add clsDC
    Set clsDC = Nothing

    '添加 月列表 左按钮
    Set conCommandButton = Me.Controls.Add("Forms.CommandButton.1", "Month-")
    With conCommandButton
        .Left = 120
        .width = 25
        .Height = 18
        .Caption = "<<<"
    End With
    clsDC.ReceiveCommandButton conCommandButton
    co.Add clsDC
    Set clsDC = Nothing

    '添加 月列表
    Set conComboBox = Me.Controls.Add("Forms.ComboBox.1", "ComboBoxMonth")
    With conComboBox
        For i = 1 To 12
            .AddItem i
        Next
        .Left = 145
        .width = 40
        .Height = 18
        .Value = Month(myDate)
        .Font.Size = 12
        .ListWidth = 40
        .ColumnWidths = 18
        .Style = fmStyleDropDownList
    End With
    clsDC.ReceiveComboBox conComboBox
    co.Add clsDC
    Set clsDC = Nothing

    '添加 月列表 右按钮
    Set conCommandButton = Me.Controls.Add("Forms.CommandButton.1", "Month+")
    With conCommandButton
        .Left = 185
        .width = 25
        .Height = 18
        .Caption = ">>>"
    End With
    clsDC.ReceiveCommandButton conCommandButton
    co.Add clsDC
    Set clsDC = Nothing
End Sub

'添加星期标签
Private Sub AddLabel_Week()
    Dim iCol As Integer         '列数
    Dim vWeek As Variant        '星期几
    Dim vForeColor As Variant   '前景色(文本颜色)
    '初始化 星期几 数组
    vWeek = WeekName
    '初始化 Label 前景色
    vForeColor = myColor

    '添加星期标签
    For iCol = LBound(vWeek) To UBound(vWeek)
        With Me.Controls.Add("Forms.Label.1", vWeek(iCol))
            .Top = 19
            .Left = iCol * 30
            .width = 30
            .Height = 11
            .Caption = vWeek(iCol)
            .ForeColor = vForeColor(iCol)
            .BorderStyle = fmBorderStyleSingle
        End With
    Next
End Sub

'添加日期标签
Public Sub AddLabel_Day(ByVal myDate As Date, ByVal isInit As Boolean)
    Dim i As Long               '循环变量
    Dim iCol As Integer         '列数
    Dim iRow As Integer         '行数
    Dim vForeColor As Variant   '前景色(文本颜色)
    Dim datStartDay As Date     '开始日期
    Dim datLastDay As Date      '结尾日期
    Dim conLabel As Control

    Dim oHeight As Integer

    'Set co = Nothing

    '设置窗体的Caption
    'Me.Caption = myDate

    '删除原有的日期标签
    For Each conLabel In Controls
        If conLabel.Name Like "LabelDay*" Then Controls.Remove conLabel.Name
    Next

    '初始化 Label 前景色
    vForeColor = myColor

    '取得开始日期
    datStartDay = DateSerial(Year(myDate), Month(myDate), 1)
    datStartDay = datStartDay - Weekday(datStartDay) + 1
    '取得结尾日期
    datLastDay = DateSerial(Year(myDate), Month(myDate) + 1, 0)
    datLastDay = datLastDay + 7 - Weekday(datLastDay)

    For i = datStartDay To datLastDay
        iCol = (i - datStartDay) Mod 7
        iRow = Int((i - datStartDay) / 7)
        Set conLabel = Me.Controls.Add("Forms.Label.1", "LabelDay" & i)
        With conLabel
            .Top = iRow * 13 + 30
            .Left = iCol * 30
            .width = 30
            .Height = 13
            .Caption = Day(i)
            .Font.Size = 12
            .Font.Bold = True
            .TextAlign = fmTextAlignCenter
            .BorderStyle = fmBorderStyleSingle

            '设置前景色，如果日期不在本月的，设成灰色
            If Month(i) = Month(myDate) Then
                .ForeColor = vForeColor(iCol)
            Else
                .ForeColor = RGB(150, 150, 150)
            End If

            '设置当前日期标签的背景色
            If i = myDate Then
                .BackColor = RGB(0, 100, 250)
                sLabelName = .Name      '当前日期标签的名称赋给变量备用
            End If
        End With
        clsDC.ReceiveLabel conLabel
        co.Add clsDC
        Set clsDC = Nothing
    Next

    oHeight = (iRow + 1) * 13 + 30 + 24    ' 119  ' 正常月份是5行，这个值是119；特殊月份是6行，比如2020-4，这个值是132

    Me.Height = oHeight + 20  '之前的代码是oHeight，我加了30的时间区域。 把之前的oHeight作为参数值返回
    AddDatetime myDate, oHeight, isInit

End Sub

Private Sub AddDatetime(ByVal myDate As Date, ByVal fHeight As Integer, ByVal isInit As Boolean)
    Dim i As Integer
    Dim conCommandButton As MSForms.CommandButton
    Dim conComboBox As MSForms.ComboBox
    Dim conLabel As Control
    Dim mControl As Control
    Dim dTop As Integer
    dTop = fHeight - 20

    Dim cHour As String
    Dim cMinute As String
    Dim cSecond As String

    If isInit Then
        cHour = "00"
        cMinute = "00"
        cSecond = "00"

    Else
        cHour = Me.Controls("DatetimeComboBoxHour").Value
        cMinute = Me.Controls("DatetimeComboBoxMinute").Value
        cSecond = Me.Controls("DatetimeComboBoxSecond").Value

        '删除原有的AddDatetime添加的控件
        For Each mControl In Controls
            If mControl.Name Like "Datetime*" Then Controls.Remove mControl.Name
        Next

    End If

    Set conLabel = Me.Controls.Add("Forms.Label.1", "DatetimeLabel")
     With conLabel
        .Top = dTop + 2
        .Left = 3
        .width = 89
        .Height = 13
        .Caption = "时间（时分秒）:"
        .Font.Size = 11
        .TextAlign = fmTextAlignCenter
        .BorderStyle = fmBorderStyleSingle
    End With

    '添加 小时列表
    Set conComboBox = Me.Controls.Add("Forms.ComboBox.1", "DatetimeComboBoxHour")
    With conComboBox
        For i = 0 To 12
            If i < 10 Then
                .AddItem "0" & i
             Else
                .AddItem i
            End If
        Next
        .Left = 100
        .Top = dTop
        .width = 35
        .Height = 18
        .Value = cHour
        .Font.Size = 12
        .ListWidth = 40
        .ColumnWidths = 18
        .Style = fmStyleDropDownList
    End With
    clsDC.ReceiveComboBox conComboBox
    co.Add clsDC
    Set clsDC = Nothing

    '添加 分钟列表
    Set conComboBox = Me.Controls.Add("Forms.ComboBox.1", "DatetimeComboBoxMinute")
    With conComboBox
        For i = 0 To 60
            If i < 10 Then
                .AddItem "0" & i
             Else
                .AddItem i
            End If
        Next
        .Left = 136
        .Top = dTop
        .width = 35
        .Height = 18
        .Value = "00"
        .Font.Size = 12
        .ListWidth = 40
        .ColumnWidths = 18
        .Style = fmStyleDropDownList
    End With
    clsDC.ReceiveComboBox conComboBox
    co.Add clsDC
    Set clsDC = Nothing

    '添加 秒钟列表
    Set conComboBox = Me.Controls.Add("Forms.ComboBox.1", "DatetimeComboBoxSecond")
    With conComboBox
        For i = 0 To 60
            If i < 10 Then
                .AddItem "0" & i
             Else
                .AddItem i
            End If
        Next
        .Left = 172
        .Top = dTop
        .width = 35
        .Height = 18
        .Value = "00"
        .Font.Size = 12
        .ListWidth = 40
        .ColumnWidths = 18
        .Style = fmStyleDropDownList
    End With
    clsDC.ReceiveComboBox conComboBox
    co.Add clsDC
    Set clsDC = Nothing

    '设置窗体的Caption
    Me.Caption = Format(myDate, "yyyy/mm/dd") & " " & cHour & ":" & cMinute & ":" & cSecond
    'clsDC.setCaption (myDate)

End Sub

'初始化 星期几 数组
Private Function WeekName()
    WeekName = Array("星期日", "星期一", "星期二", "星期三", "星期四", "星期五", "星期六")
End Function

'初始化 前景色
Private Function myColor()
    myColor = Array(vbRed, 0, 0, 0, 0, 0, vbRed)
End Function
vieyahn2017 commented 3 years ago

sheet

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Row > 1 And Target.Column = 4 Then
        With UsFormDateControl
            .Show
            .StartUpPosition = 0
            .Left = Target.Left + 25
            .Top = Target.Top + 175

            '.Top = ActiveWindow.PointsToScreenPixelsY(Target.Top)
            '.Left = ActiveWindow.PointsToScreenPixelsX(Target.Left)
        End With
    End If
    Target.Activate
End Sub
vieyahn2017 commented 3 years ago

原始代码如下

vieyahn2017 commented 3 years ago

类模块 DateControl

Option Explicit

Private WithEvents conLabel As MSForms.Label
Private WithEvents conComboBox As MSForms.ComboBox
Private WithEvents conCommandButton As MSForms.CommandButton

Property Get myDate() As Date
    With UsFormDateControl
        myDate = CDate(.Caption)
    End With
End Property

Public Sub ReceiveLabel(ByVal reLabel As MSForms.Label)
    Set conLabel = reLabel
End Sub

Public Sub ReceiveComboBox(ByVal reComboBox As MSForms.ComboBox)
    Set conComboBox = reComboBox
End Sub

Public Sub ReceiveCommandButton(ByVal reCommandButton As MSForms.CommandButton)
    Set conCommandButton = reCommandButton
End Sub

Private Sub conComboBox_Change()
    With UsFormDateControl
        .AddLabel_Day DateSerial(.Controls("ComboBoxYear"), .Controls("ComboBoxMonth"), Day(.Caption))
    End With
End Sub

Private Sub conCommandButton_Click()
    Dim iTmp As Integer
    With UsFormDateControl
        Select Case conCommandButton.Name
            Case "Year-"
                iTmp = .Controls("ComboBoxYear").Value
                If iTmp <> 1900 Then .Controls("ComboBoxYear").Value = iTmp - 1
            Case "Year+"
                iTmp = .Controls("ComboBoxYear").Value
                If iTmp <> 2999 Then .Controls("ComboBoxYear").Value = iTmp + 1
            Case "Month-"
                iTmp = .Controls("ComboBoxMonth").Value
                .Controls("ComboBoxMonth").Value = IIf(iTmp - 1 Mod 12, iTmp - 1, 12)
            Case "Month+"
                iTmp = .Controls("ComboBoxMonth").Value
                .Controls("ComboBoxMonth").Value = IIf(iTmp Mod 12, iTmp + 1, 1)
        End Select
    End With
End Sub

Private Sub conLabel_Click()
    Dim sTmp As String

    With UsFormDateControl
        .Caption = CDate(Replace(conLabel.Name, "LabelDay", ""))

        sTmp = .sLabelName

        conLabel.BackColor = RGB(0, 100, 250)
        If sTmp <> conLabel.Name And Len(sTmp) > 0 Then
            On Error Resume Next
            .Controls(sTmp).BackColor = RGB(230, 230, 230)
            On Error GoTo 0
        End If
        .sLabelName = conLabel.Name

        '如果选中其他月份的标签，重置日期。
        If Month(.Caption) <> Val(.Controls("ComboBoxMonth").Value) Then
            .AddLabel_Day myDate
            .Controls("ComboBoxMonth").Value = Month(.Caption)
        End If
    End With

    If TypeName(Selection) = "Range" Then
        Selection = myDate
    End If

    Unload UsFormDateControl
End Sub

窗体

Option Explicit

Private clsDC As New DateControl
Private co As New Collection
Public sLabelName As String

'窗体加载
Private Sub UserForm_Initialize()
    With Me
        .Width = 214
    End With
    AddHead Date
    AddLabel_Week
    AddLabel_Day Date
    Me.Controls("ComboBoxYear").SetFocus
End Sub

'添加 头部控件
Private Sub AddHead(ByVal myDate As Date)
    Dim i As Integer
    Dim conCommandButton As MSForms.CommandButton
    Dim conComboBox As MSForms.ComboBox

    '添加 年列表 左按钮
    Set conCommandButton = Me.Controls.Add("Forms.CommandButton.1", "Year-")
    With conCommandButton
        .Width = 25
        .Height = 18
        .Caption = "<<<"
    End With
    clsDC.ReceiveCommandButton conCommandButton
    co.Add clsDC
    Set clsDC = Nothing

    '添加 年列表
    Set conComboBox = Me.Controls.Add("Forms.ComboBox.1", "ComboBoxYear")
    With conComboBox
        For i = 1900 To 2999
            .AddItem i
        Next
        .Left = 25
        .Width = 60
        .Height = 18
        .Value = Year(myDate)
        .Font.Size = 12
        .ListWidth = 60
        .ColumnWidths = 18
        .Style = fmStyleDropDownList
    End With
    clsDC.ReceiveComboBox conComboBox
    co.Add clsDC
    Set clsDC = Nothing

    '添加 年列表 右按钮
    Set conCommandButton = Me.Controls.Add("Forms.CommandButton.1", "Year+")
    With conCommandButton
        .Left = 85
        .Width = 25
        .Height = 18
        .Caption = ">>>"
    End With
    clsDC.ReceiveCommandButton conCommandButton
    co.Add clsDC
    Set clsDC = Nothing

    '添加 月列表 左按钮
    Set conCommandButton = Me.Controls.Add("Forms.CommandButton.1", "Month-")
    With conCommandButton
        .Left = 120
        .Width = 25
        .Height = 18
        .Caption = "<<<"
    End With
    clsDC.ReceiveCommandButton conCommandButton
    co.Add clsDC
    Set clsDC = Nothing

    '添加 月列表
    Set conComboBox = Me.Controls.Add("Forms.ComboBox.1", "ComboBoxMonth")
    With conComboBox
        For i = 1 To 12
            .AddItem i
        Next
        .Left = 145
        .Width = 40
        .Height = 18
        .Value = Month(myDate)
        .Font.Size = 12
        .ListWidth = 40
        .ColumnWidths = 18
        .Style = fmStyleDropDownList
    End With
    clsDC.ReceiveComboBox conComboBox
    co.Add clsDC
    Set clsDC = Nothing

    '添加 月列表 右按钮
    Set conCommandButton = Me.Controls.Add("Forms.CommandButton.1", "Month+")
    With conCommandButton
        .Left = 185
        .Width = 25
        .Height = 18
        .Caption = ">>>"
    End With
    clsDC.ReceiveCommandButton conCommandButton
    co.Add clsDC
    Set clsDC = Nothing
End Sub

'添加星期标签
Private Sub AddLabel_Week()
    Dim iCol As Integer         '列数
    Dim vWeek As Variant        '星期几
    Dim vForeColor As Variant   '前景色(文本颜色)
    '初始化 星期几 数组
    vWeek = WeekName
    '初始化 Label 前景色
    vForeColor = myColor

    '添加星期标签
    For iCol = LBound(vWeek) To UBound(vWeek)
        With Me.Controls.Add("Forms.Label.1", vWeek(iCol))
            .Top = 19
            .Left = iCol * 30
            .Width = 30
            .Height = 11
            .Caption = vWeek(iCol)
            .ForeColor = vForeColor(iCol)
            .BorderStyle = fmBorderStyleSingle
        End With
    Next
End Sub

'添加日期标签
Public Sub AddLabel_Day(ByVal myDate As Date)
    Dim i As Long               '循环变量
    Dim iCol As Integer         '列数
    Dim iRow As Integer         '行数
    Dim vForeColor As Variant   '前景色(文本颜色)
    Dim datStartDay As Date     '开始日期
    Dim datLastDay As Date      '结尾日期
    Dim conLabel As control

    'Set co = Nothing

    '设置窗体的Caption
    Me.Caption = myDate

    '删除原有的日期标签
    For Each conLabel In Controls
        If conLabel.Name Like "LabelDay*" Then Controls.Remove conLabel.Name
    Next

    '初始化 Label 前景色
    vForeColor = myColor

    '取得开始日期
    datStartDay = DateSerial(Year(myDate), Month(myDate), 1)
    datStartDay = datStartDay - WeekDay(datStartDay) + 1
    '取得结尾日期
    datLastDay = DateSerial(Year(myDate), Month(myDate) + 1, 0)
    datLastDay = datLastDay + 7 - WeekDay(datLastDay)

    For i = datStartDay To datLastDay
        iCol = (i - datStartDay) Mod 7
        iRow = Int((i - datStartDay) / 7)
        Set conLabel = Me.Controls.Add("Forms.Label.1", "LabelDay" & i)
        With conLabel
            .Top = iRow * 13 + 30
            .Left = iCol * 30
            .Width = 30
            .Height = 13
            .Caption = Day(i)
            .Font.Size = 12
            .Font.Bold = True
            .TextAlign = fmTextAlignCenter
            .BorderStyle = fmBorderStyleSingle

            '设置前景色，如果日期不在本月的，设成灰色
            If Month(i) = Month(myDate) Then
                .ForeColor = vForeColor(iCol)
            Else
                .ForeColor = RGB(150, 150, 150)
            End If

            '设置当前日期标签的背景色
            If i = myDate Then
                .BackColor = RGB(0, 100, 250)
                sLabelName = .Name      '当前日期标签的名称赋给变量备用
            End If
        End With
        clsDC.ReceiveLabel conLabel
        co.Add clsDC
        Set clsDC = Nothing
    Next
    Me.Height = (iRow + 1) * 13 + 30 + 24
End Sub

'初始化 星期几 数组
Private Function WeekName()
    WeekName = Array("星期日", "星期一", "星期二", "星期三", "星期四", "星期五", "星期六")
End Function

'初始化 前景色
Private Function myColor()
    myColor = Array(vbRed, 0, 0, 0, 0, 0, vbRed)
End Function

sheet

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Row > 1 And Target.Column = 4 Then
        With UsFormDateControl
            .Show
            .StartUpPosition = 0
            .Left = Target.Left + 25
            .Top = Target.Top + 175

            '.Top = ActiveWindow.PointsToScreenPixelsY(Target.Top)
            '.Left = ActiveWindow.PointsToScreenPixelsX(Target.Left)
        End With
    End If
    Target.Activate
End Sub
vieyahn2017 commented 3 years ago

改动的点

vieyahn2017 commented 3 years ago

类模块 DateControl 改动部分


Private Sub conComboBox_Change()
    ' 我新加的更改时间的代码
    If InStr(conComboBox.Name, "DatetimeComboBox") Then
        setCaption (myDate())

        If typeName(Selection) = "Range" Then
            Selection = UsFormDateControl.Caption
        End If

        Exit Sub
    End If

    ' 原有的更改年月的代码   【只有这三行】
    With UsFormDateControl
        .AddLabel_Day DateSerial(.Controls("ComboBoxYear"), .Controls("ComboBoxMonth"), Day(.Caption)), False
    End With

    If typeName(Selection) = "Range" Then
            Selection = UsFormDateControl.Caption
    End If
End Sub

Private Sub conLabel_Click()
    Dim sTmp As String

    With UsFormDateControl

        '原代码
        '.Caption = CDate(Replace(conLabel.Name, "LabelDay", ""))
        setCaption (CDate(Replace(conLabel.Name, "LabelDay", "")))

        sTmp = .sLabelName

        conLabel.BackColor = RGB(0, 100, 250)
        If sTmp <> conLabel.Name And Len(sTmp) > 0 Then
            On Error Resume Next
            .Controls(sTmp).BackColor = RGB(230, 230, 230)
            On Error GoTo 0
        End If
        .sLabelName = conLabel.Name

        '如果选中其他月份的标签，重置日期。
        If Month(.Caption) <> Val(.Controls("ComboBoxMonth").Value) Then
            .AddLabel_Day myDate, False   '新代码 增加了第二个参数
            .Controls("ComboBoxMonth").Value = Month(.Caption)
        End If
    End With

    If typeName(Selection) = "Range" Then
        '原代码
        ’Selection = myDate
        Selection = UsFormDateControl.Caption
    End If

    'Unload UsFormDateControl
End Sub

'新增的方法

Public Sub setCaption(ByVal myDate As Date)

    Dim cHour As String
    Dim cMinute As String
    Dim cSecond As String

    With UsFormDateControl
        cHour = .Controls("DatetimeComboBoxHour").Value
        cMinute = .Controls("DatetimeComboBoxMinute").Value
        cSecond = .Controls("DatetimeComboBoxSecond").Value

        '设置窗体的Caption
        .Caption = Format(myDate, "yyyy/mm/dd") & " " & cHour & ":" & cMinute & ":" & cSecond

    End With

End Sub
vieyahn2017 commented 3 years ago

窗体UsFormDateControl 代码，改动部分


Option Explicit

Private clsDC As New DateControl
Private co As New Collection
Public sLabelName As String

'窗体加载
Private Sub UserForm_Initialize()
    With Me
        .width = 214
    End With
    AddHead Date
    AddLabel_Week
    AddLabel_Day Date, True   ' 增加了第二个参数
    Me.Controls("ComboBoxYear").SetFocus
End Sub

'添加 头部控件
Private Sub AddHead(ByVal myDate As Date)
    ' 原代码不变 '
End Sub

'添加星期标签
Private Sub AddHead(ByVal myDate As Date)
    ' 原代码不变 '
End Sub

'添加日期标签
Public Sub AddLabel_Day(ByVal myDate As Date, ByVal isInit As Boolean)
    Dim i As Long               '循环变量
    Dim iCol As Integer         '列数
    Dim iRow As Integer         '行数
    Dim vForeColor As Variant   '前景色(文本颜色)
    Dim datStartDay As Date     '开始日期
    Dim datLastDay As Date      '结尾日期
    Dim conLabel As Control

    '增加了一个窗体高度变量
    Dim oHeight As Integer

    'Set co = Nothing

    '设置窗体的Caption
    'Me.Caption = myDate

    '删除原有的日期标签
    For Each conLabel In Controls
        If conLabel.Name Like "LabelDay*" Then Controls.Remove conLabel.Name
    Next

    '初始化 Label 前景色
    vForeColor = myColor

    '取得开始日期
    datStartDay = DateSerial(Year(myDate), Month(myDate), 1)
    datStartDay = datStartDay - Weekday(datStartDay) + 1
    '取得结尾日期
    datLastDay = DateSerial(Year(myDate), Month(myDate) + 1, 0)
    datLastDay = datLastDay + 7 - Weekday(datLastDay)

    For i = datStartDay To datLastDay
        iCol = (i - datStartDay) Mod 7
        iRow = Int((i - datStartDay) / 7)
        Set conLabel = Me.Controls.Add("Forms.Label.1", "LabelDay" & i)
        With conLabel
            .Top = iRow * 13 + 30
            .Left = iCol * 30
            .width = 30
            .Height = 13
            .Caption = Day(i)
            .Font.Size = 12
            .Font.Bold = True
            .TextAlign = fmTextAlignCenter
            .BorderStyle = fmBorderStyleSingle

            '设置前景色，如果日期不在本月的，设成灰色
            If Month(i) = Month(myDate) Then
                .ForeColor = vForeColor(iCol)
            Else
                .ForeColor = RGB(150, 150, 150)
            End If

            '设置当前日期标签的背景色
            If i = myDate Then
                .BackColor = RGB(0, 100, 250)
                sLabelName = .Name      '当前日期标签的名称赋给变量备用
            End If
        End With
        clsDC.ReceiveLabel conLabel
        co.Add clsDC
        Set clsDC = Nothing
    Next

    '增加了三行
    oHeight = (iRow + 1) * 13 + 30 + 24    ' 119  ' 正常月份是5行，这个值是119；特殊月份是6行，比如2020-4，这个值是132

    Me.Height = oHeight + 20  '之前的代码是oHeight，我加了30的时间区域。 把之前的oHeight作为参数值返回
    AddDatetime myDate, oHeight, isInit

End Sub

' 新增的日期选择功能
Private Sub AddDatetime(ByVal myDate As Date, ByVal fHeight As Integer, ByVal isInit As Boolean)
    Dim i As Integer
    Dim conCommandButton As MSForms.CommandButton
    Dim conComboBox As MSForms.ComboBox
    Dim conLabel As Control
    Dim mControl As Control
    Dim dTop As Integer
    dTop = fHeight - 20

    Dim cHour As String
    Dim cMinute As String
    Dim cSecond As String

    If isInit Then
        cHour = "00"
        cMinute = "00"
        cSecond = "00"

    Else
        cHour = Me.Controls("DatetimeComboBoxHour").Value
        cMinute = Me.Controls("DatetimeComboBoxMinute").Value
        cSecond = Me.Controls("DatetimeComboBoxSecond").Value

        '删除原有的AddDatetime添加的控件
        For Each mControl In Controls
            If mControl.Name Like "Datetime*" Then Controls.Remove mControl.Name
        Next

    End If

    Set conLabel = Me.Controls.Add("Forms.Label.1", "DatetimeLabel")
     With conLabel
        .Top = dTop + 2
        .Left = 3
        .width = 89
        .Height = 13
        .Caption = "时间（时分秒）:"
        .Font.Size = 11
        .TextAlign = fmTextAlignCenter
        .BorderStyle = fmBorderStyleSingle
    End With

    '添加 小时列表
    Set conComboBox = Me.Controls.Add("Forms.ComboBox.1", "DatetimeComboBoxHour")
    With conComboBox
        For i = 0 To 12
            If i < 10 Then
                .AddItem "0" & i
             Else
                .AddItem i
            End If
        Next
        .Left = 100
        .Top = dTop
        .width = 35
        .Height = 18
        .Value = cHour
        .Font.Size = 12
        .ListWidth = 40
        .ColumnWidths = 18
        .Style = fmStyleDropDownList
    End With
    clsDC.ReceiveComboBox conComboBox
    co.Add clsDC
    Set clsDC = Nothing

    '添加 分钟列表
    Set conComboBox = Me.Controls.Add("Forms.ComboBox.1", "DatetimeComboBoxMinute")
    With conComboBox
        For i = 0 To 60
            If i < 10 Then
                .AddItem "0" & i
             Else
                .AddItem i
            End If
        Next
        .Left = 136
        .Top = dTop
        .width = 35
        .Height = 18
        .Value = "00"
        .Font.Size = 12
        .ListWidth = 40
        .ColumnWidths = 18
        .Style = fmStyleDropDownList
    End With
    clsDC.ReceiveComboBox conComboBox
    co.Add clsDC
    Set clsDC = Nothing

    '添加 秒钟列表
    Set conComboBox = Me.Controls.Add("Forms.ComboBox.1", "DatetimeComboBoxSecond")
    With conComboBox
        For i = 0 To 60
            If i < 10 Then
                .AddItem "0" & i
             Else
                .AddItem i
            End If
        Next
        .Left = 172
        .Top = dTop
        .width = 35
        .Height = 18
        .Value = "00"
        .Font.Size = 12
        .ListWidth = 40
        .ColumnWidths = 18
        .Style = fmStyleDropDownList
    End With
    clsDC.ReceiveComboBox conComboBox
    co.Add clsDC
    Set clsDC = Nothing

    '设置窗体的Caption
    Me.Caption = Format(myDate, "yyyy/mm/dd") & " " & cHour & ":" & cMinute & ":" & cSecond
    'clsDC.setCaption (myDate)