对使用的Microsoft Forms 2.0 object Liebrary控件，在VB中也有这个控件，但就是在做不成呢
调用就是一句：
Call Form2.设置日期(Text1.Text, Text1, Me)
参数说明：第一个是设置初始日期，第二个控件，是用来接收返回结果的，第三个是调用的窗体，用来计算日历窗体位置的
这是日历窗体代码
程序代码：Option Explicit
Const 颜色1 = 8421504 '灰色，用于非本月日期
Const 颜色2 = 16711680 '蓝色，用于本月日期
Const 颜色3 = 8421631 '红色，用于本日
Const 颜色4 = -2147483633 '系统颜色，窗体背景
Dim pubolddate As Date '保存进入的日期
Dim pubdate As Date '保存日期
Dim Cancel As Boolean '是否取消了
Dim dateobj As Object '保存需要结果的那个控件
Dim datefrm As Form '保存调用本窗口的窗体
Dim mov As Long '上次的控件编号
Dim dd(42) As Date
Private Sub Command1_Click()
pubdate = DateAdd("yyyy", -1, pubdate) '减少一年
Call 排列日期
End Sub
Private Sub Command2_Click()
pubdate = DateAdd("yyyy", 1, pubdate) '增加一年
Call 排列日期
End Sub
Private Sub Command3_Click()
pubdate = DateAdd("m", -1, pubdate) '减少一月
Call 排列日期
End Sub
Private Sub Command4_Click()
pubdate = DateAdd("m", 1, pubdate) '增加一月
Call 排列日期
End Sub
Private Sub Command5_Click()
Cancel = True '取消
Unload Me
End Sub
Private Sub ds_Click(Index As Integer)
pubdate = dd(Index)
Unload Me '关掉本窗体，自动返回结果
End Sub
Private Sub Form_GotFocus()
'
MsgBox 1
End Sub
Private Sub Form_Load()
Combo1.AddItem "一月"
Combo1.AddItem "二月"
Combo1.AddItem "三月"
Combo1.AddItem "四月"
Combo1.AddItem "五月"
Combo1.AddItem "六月"
Combo1.AddItem "七月"
Combo1.AddItem "八月"
Combo1.AddItem "九月"
Combo1.AddItem "十月"
Combo1.AddItem "十一月"
Combo1.AddItem "十二月"
Call 排列日期
End Sub
Private Sub ds_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If mov <> Index Then
If mov > -1 Then '此处要增加取消，是为了防止鼠标移动过快时，捕捉窗体移动无法取消
ds(mov).Appearance = 0 '取消沉下去的效果
ds(mov).BorderStyle = 0
ds(mov).BackColor = 颜色4 '恢复背景色
If Month(dd(mov)) <> Month(pubdate) Then '设置颜色，根据月份变颜色
ds(mov).ForeColor = 颜色1
Else
ds(mov).ForeColor = 颜色2
End If
If dd(mov) = pubolddate And mov < 42 Then '如果是当前日期 ,42是今天日期，不能显红
ds(mov).BackColor = 颜色3
End If
End If
ds(Index).Appearance = 1
ds(Index).BorderStyle = 1
If Month(dd(Index)) <> Month(pubdate) Then '设置颜色，根据月份变颜色
ds(Index).ForeColor = 颜色1
Else
ds(Index).ForeColor = 颜色2
End If
If dd(Index) = pubolddate And Index < 42 Then '如果是当前日期 ,42是今天日期，不能显红
ds(Index).BackColor = 颜色3
End If
mov = Index '设置下一次要弹起来的控件的索引号
End If
End Sub
Private Sub 排列日期()
Dim i As Long '共多少天
Dim j As Date '本月第一天
Dim k As Long '循环变量
Dim o As Long '本月第一天的单元格编号
Dim ne As Long '年
Dim ye As Long '月
If pubdate = "00:00:00" Then '如果没有调用日期进行使用，就用今天的日期
pubdate = Date
pubolddate = pubdate
End If
ne = Year(pubdate) '取年
ye = Month(pubdate) '取月
j = CDate(ne & "-" & ye & "-1") '本月第一天
o = Format(j, "w", vbSunday) - 1 '得到本月第一天的单元格编号
'得到本月最后一天的日期
i = Day(DateAdd("m", 1, j) - 1) '本月最后一天
For k = 0 To o - 1
dd(k) = j - o '设置标签对应的日期
ds(k).Caption = Day(dd(k)) '设置标签名字
ds(k).ForeColor = 颜色1 '设置字体颜色
If dd(k) = pubolddate Then '如果是当前日期
ds(k).BackColor = 颜色3
Else
ds(k).BackColor = 颜色4
End If
Next k
For k = o To o + i - 1
ds(k).Caption = k - o + 1
dd(k) = j + k - o
ds(k).ForeColor = 颜色2
If dd(k) = pubolddate Then '如果是当前日期
ds(k).BackColor = 颜色3
Else
ds(k).BackColor = 颜色4
End If
Next k
For k = o + i To 41
dd(k) = j + k - o
ds(k).Caption = k - o - i + 1
ds(k).ForeColor = 颜色1
If dd(k) = pubolddate Then '如果是当前日期
ds(k).BackColor = 颜色3
Else
ds(k).BackColor = 颜色4
End If
Next k
ds(42).Caption = "今天是：" & Date '设置今天
dd(42) = Date
If Month(dd(42)) <> Month(pubdate) Then '设置字体颜色
ds(42).ForeColor = 颜色1
Else
ds(42).ForeColor = 颜色2
End If
Label1.Caption = ne '显示年
Combo1.ListIndex = ye - 1 '显示月
'If Me.Visible And Command5.Visible Then
' Command5.SetFocus '焦点还是移到关闭按钮上面
'End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If mov > -1 Then
ds(mov).Appearance = 0 '取消沉下去的效果
ds(mov).BorderStyle = 0
ds(mov).BackColor = -2147483633 '恢复背景色
If Month(dd(mov)) <> Month(pubdate) Then '设置字体颜色
ds(mov).ForeColor = 颜色1
Else
ds(mov).ForeColor = 颜色2
End If
If dd(mov) = pubolddate And mov < 42 Then '如果是当前日期 ,42是今天日期，不能显红
ds(mov).BackColor = 颜色3
End If
mov = -1
End If
End Sub
Public Sub 设置日期(日期 As Date, 返回结果 As Object, 窗体 As Form, Optional 坐标X As Long, Optional 坐标Y As Long)
pubdate = 日期
pubolddate = pubdate
Call 排列日期
Set dateobj = 返回结果
Set datefrm = 窗体
'确定日历窗体显示的位置
Dim i As Long
i = 窗体.Height - 窗体.ScaleHeight '取得标题的高度
Me.Left = 窗体.Left + 返回结果.Left
Me.Top = 窗体.Top + 返回结果.Top + i + 返回结果.Height
Me.Show vbModal '使用有模式的方式显示窗体，所以必须提示一个关闭按纽
End Sub
Private Sub Form_Unload(Cancel As Integer)
If Cancel Then '如果是取消，那么还原数据
pubdate = pubolddate
End If
If TypeName(dateobj) = "TextBox" Then '如果对应是 text ，则使用 text 属性
dateobj.Text = pubdate
ElseIf TypeName(dateobj) = "Label" Then '如果对象是 label ，则使用 caption 属性
dateobj.Caption = pubdate
End If
End Sub
日历.rar
(4.89 KB)
