自建日历选择窗口取代VBA日历控件mscomct2.ocx解决兼容问题

向東 · 发表于 2018-8-21 15:18

本帖最后由向東于 2018-8-21 15:29 编辑

对于VBA日历控件，之前因为Excel版本兼容问题，
想着自己来写一个程序取代VBA日历控件，
来解决版本不兼容的问题，后来经过研究摸索，
又参考了别人写的代码，终于写成了。

这个完全解决了版本兼容的问题，不管Excel 2003还是2016，
不管32位还是64位，都能正常使用！

因为一直在我写的一个小程序里用着，没有单独拿出来，
今天有空就分离了出来，给大家分享一下！
里面注释很详细，原理说的比较清楚，稍微改造一下就能用了。

另外：
里面的CalendarForm窗口，模块bindBuntonModule，类模块buttonEvent可以导出，
然后在导入到你想使用的VBE中就可以了，窗口的格式及其中的代码都会保留，
这样也方便改造使用。注意，改造的时候CalendarForm窗口，类模块buttonEvent中
含有使用自定义窗口frm_query的代码，需要换成你自己的。

日历控件.JPG

核心代码：

Private Sub bottonDate(sMonth As Date, eMonth As Date) '42个日期按钮,为每个按钮写上对应的日期值 (此处是代码比较难理解)
Dim i As Long
Dim Y As Integer, m As Integer
Y = Year(sMonth)
m = Month(eMonth)
For i = 1 To 42 '42个日期按钮,为每个按钮写上对应的日期值
With Me.Controls("CommandButton" & i)
If i >= Weekday(sMonth, vbMonday) And i <= Weekday(sMonth, vbMonday) + Day(eMonth) - 1 Then '开始日期和结束日期之间对应的按钮
'选择月1号对应的按钮编号等于选择月份的1号对应的星期数；最后一个按钮的编号等于第一个按钮编号加上选择月份的总天数（Day(eMonth)）减去1
.Caption = i - Weekday(sMonth, vbMonday) + 1 '按钮的标题设置为当前按钮的编号减去选择月1号对应的按钮编号加上 1
.ControlTipText = "" '清除按钮上的提示文字
.Tag = "" '清除附加信息
If (i + 1) Mod 7 = 0 Or i Mod 7 = 0 Then '周六、周日
.ForeColor = &HFF& '字体设为红色色
Else
.ForeColor = &H80000012 '字体设为黑色
End If
If i = Day(Date) + Weekday(sMonth, vbMonday) - 1 And Y = Year(Date) And m = Month(Date) Then '如果某按钮上是今天的日期
.BackColor = &HC0FFFF 'vbYellow '将今日对应的按钮背景色改成浅黄
.ControlTipText = "今日" '设置按钮上的提示文字
Else
.BackColor = RGB(255, 255, 255) '其它按钮的背景色显示为活动状态颜色
End If
If i = Val(TextBoxD.Value) + Weekday(sMonth, vbMonday) - 1 Then .SetFocus '如果某按钮上是设置的日期给按钮设置焦点
ElseIf i < 7 Then '选择月份的上个月的最后几天
.Caption = Day(DateSerial(Y, m, 0)) - Weekday(sMonth, vbMonday) + i + 1 '按钮的标题设置为当前按钮的编号减去选择月1号对应的按钮编号加上 1
.ControlTipText = m - 1 & "月" & .Caption & "日" '添加按钮上的提示文字上月
.Tag = m - 1 '附加信息为上月的月份数
If (i + 1) Mod 7 = 0 Or i Mod 7 = 0 Then '周六、周日
.ForeColor = &HC0C0FF '字体设为淡红色色
Else
.ForeColor = &HC0C0C0 ' &H80000011 '字体设为灰色
End If
.BackColor = &H8000000F '设置成失活状态颜色
Else '选择月份的下个月的前几天
.Caption = i - Weekday(sMonth, vbMonday) + 1 - Day(eMonth) '按钮的标题设置为当前按钮的编号减去选择月1号对应的按钮编号加上 1
.ControlTipText = m + 1 & "月" & .Caption & "日" '添加按钮上的提示文字下月
.Tag = m + 1 '附加信息为下月的月份数
If (i + 1) Mod 7 = 0 Or i Mod 7 = 0 Then '周六、周日
.ForeColor = &HC0C0FF '字体设为淡红色色
Else
.ForeColor = &HC0C0C0 '&H80000011 '字体设为灰色
End If
.BackColor = &H8000000F '设置成失活状态颜色
End If
End With
Next
End Sub

复制代码

要是使用或者代码有任何问题欢迎指正，共同进步。

自建日历选择窗口.rar (37.74 KB, 下载次数: 1738)

补充内容 (2018-11-8 13:24):
打个补丁：
把上面代码中的
.ControlTipText = m - 1 & "月" & .Caption & "日" '添加按钮上的提示文字上月
修改一下，增加判断当前是不是1月，否则上月提示会显示0月。

补充内容 (2018-11-8 13:24):
If m - 1 = 0 Then
.ControlTipText = "12月" & .Caption & "日"  '本月是1月，添加按钮上的提示文字上月
Else
.ControlTipText = m - 1 & "月" & .Caption & "日" '添加按钮上的提示文字上月
End If

补充内容 (2018-11-8 13:25):
.ControlTipText = m + 1 & "月" & .Caption & "日"  '添加按钮上的提示文字下月
修改如下：

补充内容 (2018-11-8 13:25):
If m + 1 = 13 Then
.ControlTipText = "1月" & .Caption & "日" '本月是12月，添加按钮上的提示文字下月
Else
.ControlTipText = m + 1 & "月" & .Caption & "日"  '添加按钮上的提示文字下月
End If

补充内容 (2019-12-23 12:18):
针对大家普遍的使用需求，今天有空升级了一下代码，点选指定的单元格就会弹出日历选择窗口，如果要指定一个单元格范围，原理相同，自己酌情修改即可。
代码参见：http://club.excelhome.net/forum. ... 56&pid=10187795

补充内容 (2021-12-19 21:11):
程序再小调整一下，参见102楼：
https://club.excelhome.net/forum ... 56&pid=10856397

ζ彼岸薇蓝﹌ · 发表于 2018-8-27 01:07

真棒

向東 · 发表于 2018-9-1 07:54

不满意的地方是类模块buttonEvent中，把自定义窗口写死了，不知道如何写才好，欢迎大家指点、交流！

xu_shiqian · 发表于 2018-9-6 15:36

楼主太厉害了，希望能够跳过那该死的兼容性问题。

向東 · 发表于 2018-9-6 16:01

xu_shiqian 发表于 2018-9-6 15:36
楼主太厉害了，希望能够跳过那该死的兼容性问题。

这个全兼容，我测试过了，Excel2003到2016,32位、64位都没问题，通用。

xu_shiqian · 发表于 2018-9-9 21:41

非常感谢楼主，我已经采用你的模块完美的解决了DTPicker不兼容的问题，对你的模块稍作了改动，将年月日从选项卡里面移出来用标签显示了，并且由于我的程序中会很多地方用到时间控件，我将其做成了一个类似独立控件，输出值全送到一个单元格中，然后再通过单元格的变化送到各点击的文本框中，表现的形式与系统的时间控件完全一样。
再也不用因移动到不同电脑上要费很长时间去搞DTPicker的问题了。

xu_shiqian · 发表于 2018-9-9 21:53

主要改了类模块的输出接口
Private Sub buttonGroup_Click() 'ÈÕÆÚ°´Å¥ ÊÂ¼þ Àà

Dim Y, m As Integer
If Len(buttonGroup.Caption) = 0 Then Exit Sub

With CalendarForm
      Y = Val(.ComboBoxY.Value) 'È¥µôÓÒ±ßµÄ"Äê"
      m = Val(.ComboBoxM.Value)

      If Y < 1901 Then
         MsgBox "Äê·Ý²»ÄÜÐ¡ÓÚ1901,ÇëÖØÐÂÊäÈë£¡" 'Excel¼Ù¶¨1900ÄêÊÇÈòÄê£¬ÕâÊÇ´íÎóµÄ¡£
         .ComboBoxY.SetFocus
         Exit Sub
      End If

End With

On Error Resume Next


            If Len(buttonGroup.Tag) = 0 Then
                  Thehide.Cells(35, 1).Value = DateSerial(Y, m, buttonGroup.Caption) '¸³Öµ¸ø¿ªÊ¼ÈÕÆÚ£¨Äê-ÔÂ-ÈÕ£©  ‘输出到一个单元格
            Else
                  Thehide.Cells(35, 1).Value = DateSerial(Y, Val(buttonGroup.Tag), buttonGroup.Caption) ' ²»ÊÇ±¾ÔÂ ¸³Öµ¸ø¿ªÊ¼ÈÕÆÚ£¨Äê-ÔÂ-ÈÕ£©
            End If


CalendarForm.Hide
On Error GoTo 0
End Sub

‘所有结果均输出到同一单元格’
‘然后自己写了一个单元格的变化触发输出到不同的文本框控件的程序’

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 35 And Target.Column = 1 Then
If Thehide.Cells(35, 3).Value = "Pg2form" And Thehide.Cells(35, 2).Value = "DTPISL1" Then
      Pg2form.DTPISL1.Value = Target.Value

ElseIf Thehide.Cells(35, 3).Value = "Pg2form" And Thehide.Cells(35, 2).Value = "DTPISL2" Then
      Pg2form.DTPISL2.Value = Target.Value

ElseIf Thehide.Cells(35, 3).Value = "Pg2form" And Thehide.Cells(35, 2).Value = "DTPISL3" Then
      Pg2form.DTPISL3.Value = Target.Value

ElseIf Thehide.Cells(35, 3).Value = "Pg2form" And Thehide.Cells(35, 2).Value = "DTPISL4" Then
      Pg2form.DTPISL4.Value = Target.Value

ElseIf Thehide.Cells(35, 3).Value = "Pg2form" And Thehide.Cells(35, 2).Value = "DTPISL5" Then
      Pg2form.DTPISL5.Value = Target.Value

ElseIf Thehide.Cells(35, 3).Value = "Pg2form" And Thehide.Cells(35, 2).Value = "DTPISL6" Then
      Pg2form.DTPISL6.Value = Target.Value


ElseIf Thehide.Cells(35, 3).Value = "Pg6form" And Thehide.Cells(35, 2).Value = "DTPISL2" Then
      Pg6form.DTPISL2.Value = Target.Value

ElseIf Thehide.Cells(35, 3).Value = "Pg7form" And Thehide.Cells(35, 2).Value = "DTPISL1" Then
      Pg7form.DTPISL1.Value = Target.Value

ElseIf Thehide.Cells(35, 3).Value = "Pg7form" And Thehide.Cells(35, 2).Value = "DTPISL2" Then
      Pg7form.DTPISL2.Value = Target.Value

ElseIf Thehide.Cells(35, 3).Value = "Pg7form" And Thehide.Cells(35, 2).Value = "DTPISL3" Then
      Pg7form.DTPISL3.Value = Target.Value

ElseIf Thehide.Cells(35, 3).Value = "Pg7form" And Thehide.Cells(35, 2).Value = "DTPpayment" Then
      Pg7form.DTPpayment.Value = Target.Value


End If

End If

End Sub

这样就完美的用一个日历窗体解决了很多个日期控件的问题，表现得跟DTPicker一样。

YZC51 · 发表于 2018-9-10 07:34

xu_shiqian 发表于 2018-9-9 21:53
主要改了类模块的输出接口
Private Sub buttonGroup_Click() 'ÈÕÆÚ°´& ...

希望楼上老师能上传附件，学习下！谢谢！

向東 · 发表于 2018-9-10 08:32

xu_shiqian 发表于 2018-9-9 21:41
非常感谢楼主，我已经采用你的模块完美的解决了DTPicker不兼容的问题，对你的模块稍作了改动，将年月日从选 ...

我觉得类模块里要改一下，使得更通用。因为我的查询窗口就一个，所以也没花心思，暂时写死了，你这样改一下就解决多窗口查询的问题了。不错，值得借鉴。

xu_shiqian · 发表于 2018-10-7 20:37

因为自己的程序比较大，利用放假将模块部分导出，简单作了个示例，供参考。

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

[原创] 自建日历选择窗口取代VBA日历控件mscomct2.ocx解决兼容问题

评分

评分

评分