窗体自定义日期控件

marchwen01 · 发表于 2017-3-23 23:24

本帖最后由 marchwen01 于 2017-3-24 08:46 编辑

纯动态添加窗体控件，去除系统控件的兼容问题。原创代码。

marchwen01 · 发表于 2017-3-23 23:26

窗体代码：
窗体名称：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
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

复制代码

1207834011 · 发表于 2017-3-24 07:36

要是能加个时间选择就好了。

鄂龙蒙 · 发表于 2017-3-24 08:09

学习大师优秀作品。提个建议：当在窗体上选择【年】或【月】增减时，下面日期立即变动就更完美了。

marchwen01 · 发表于 2017-3-24 08:45

本帖最后由 marchwen01 于 2017-3-24 08:53 编辑

鄂龙蒙发表于 2017-3-24 08:09
学习大师优秀作品。提个建议：当在窗体上选择【年】或【月】增减时，下面日期立即变动就更完美了。

本来是这样做的，后来改了一个地方地，结果 ComboBox 的 Change 事件响应了却没更新到，现在可以了。谢谢提醒

现在加了一个选择日期后退出窗体的，这样如果想重选就得重新激活窗体的了。

marchwen01 · 发表于 2017-3-24 10:46

类模块代码：
类模块名称：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").Value, .Controls("ComboBoxMonth").Value, 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
End Sub

复制代码

SCL5801 · 发表于 2017-3-24 18:24

marchwen01 发表于 2017-3-24 10:46
类模块代码：
类模块名称：DateControl

我也学习大师优秀作品。也提个建议：当冻结窗口以后，窗体还能跟随鼠标就更完美了。

zbaigao · 发表于 2017-10-25 14:25

学习了学习了
学习了

yuri_lee · 发表于 2019-4-27 11:53

谢谢分享，系统中原来日期控件实在是找不到

13724340687 · 发表于 2019-7-16 22:28

marchwen01 发表于 2017-3-24 08:45
本来是这样做的，后来改了一个地方地，结果 ComboBox 的 Change 事件响应了却没更新到，现在可以了。谢谢 ...

请问大师，我要把这个自定义控件应用在用户窗体中的文本框中，怎么修改代码？乞求回复，不胜感激！

		自动登录	找回密码
密码			免费注册

[分享] 窗体自定义日期控件

评分

评分

评分