日历型窗体

时　间:2010-03-02 17:01:34
作　者:王樵民   ID：5203  城市：郑州
摘　要:本文介绍一个日历型窗体，分为Access2000,Access2003,Access2007版的三个数据库，并提供了源码，供网友参考
正　文:

本文介绍一个日历型窗体，分为Access2000,Access2003,Access2007版的三个数据库，并提供了源码，供网友参考，利用这个日历型窗体，可以制作您想要的与日期有关的数据库。

点击下载此附件

该窗体的程序如下：

Function 当前日期(日期)
Dim i, j, p, s
系统年份 = Year(Date)
当前年份 = Year(日期)
今天 = 日期
当前月份 = DatePart("m", DateSerial(Year(今天), Month(今天), 1))
天数 = Day(Date)
月份 = Month(Date)
月天数 = DatePart("d", DateSerial(Year(今天), Month(今天) + 1, 1 - 1))
星期 = Weekday(DateSerial(Year(今天), Month(今天), 1))
'MsgBox (Str(Hang) & "," & Str(ShangYue) & "," & Str(XiaYue))
j = 101
p = 1
'MsgBox (qjintian)
For i = 1 To Me.Controls.Count - 1
 If Mid(Me.Controls(i).Name, 1, 2) = "C1" Then
  'MsgBox ("C" & Mid(Str(j), 2))
  If j >= 100 + 星期 And p <= 月天数 Then
   Me.Controls(i).Caption = Mid(Str(p), 2)
   Me.Controls(i).Enabled = True
   s = "=命令接口('" & Me.Controls(i).Name & "')"
   Me.Controls(i).OnClick = s
   Me.Controls(i).Tag = Str(p)
   If 当前年份 = 系统年份 And Month(今天) = 月份 And p = 天数 Then
    Me.Controls(i).ForeColor = RGB(255, 0, 0)
    Me.Controls(i).FontBold = True
    Me.Controls(i).SetFocus
   Else
    Me.Controls(i).ForeColor = RGB(0, 0, 0)
    Me.Controls(i).FontBold = False
   End If
   p = p + 1
  Else
   Me.Controls(i).Enabled = False
   Me.Controls(i).Caption = ""
  End If
  'MsgBox (Me.Controls(I).Name)
  j = j + 1
 Else
  'MsgBox (Trim(Me.Controls(i).Name) & "---" & "C" & Mid(Str(i + 100), 2))
 End If
 'Me.Controls(i).Caption = Mid(Str(i), 2)
 'MsgBox (Mid(Str(i + 100), 2))
Next
当前日期 = 今天
End Function

Private Sub Form_Load()
qq = 当前日期(Date)
End Sub
Function 命令接口(控件名)
 Dim i
 Dim 选择日期
 i = 1
 While Me.Controls(i).Name <> 控件名
  i = i + 1
 Wend
 选择日期 = CDate(Year([x1]) & "-" & Month([x1]) & "-" & Me.Controls(i).Caption)
 MsgBox ("您选择的日期为：" & 选择日期)
 '在此处可以打开相应日期的窗体，下面的表示打开销售合同窗体
 'DoCmd.OpenForm "销售合同", acNormal, , "签订日期=#" & 选择日期 & "#"
End Function

Private Sub 上一年_Click()
Dim qq
[x1] = DateAdd("yyyy", -1, CDate([x1]))
qq = 当前日期([x1])
End Sub

Private Sub 上月_Click()
Dim qq
[x1] = DateAdd("m", -1, CDate([x1]))
qq = 当前日期([x1])
End Sub

Private Sub 下一年_Click()
Dim qq
[x1] = DateAdd("yyyy", 1, CDate([x1]))
qq = 当前日期([x1])
End Sub

Private Sub 下月_Click()
Dim qq
[x1] = DateAdd("m", 1, CDate([x1]))
qq = 当前日期([x1])
End Sub