带24节气和农历节的日历做法

来源:网 点击数:16988 　 | 收藏 | 复制

时　间:2009-04-02 19:46:36
作　者:网络 ID：1294 城市：厦门
摘　要:带24节气和农历节的日历
正　文:

带24节气和农历节的日历

2009-03-28 18:23

一、函数

Function WDateToEDate(ByVal curTime As Date) As String
    Dim MonthAdd(11), NongliData(99), TianGan(9), DiZhi(11), ShuXiang(11), DayName(30), MonName(12), TermName(1 To 24), Fday(1 To 10, 1 To 10)
    Dim curYear, curMonth, curDay, curWeekday
    Dim GongliStr, WeekdayStr, NongliStr, NongliDayStr
    Dim i, m, n, k, isEnd, bit, TheDate, TmDate1, TmDate2

    '天干名称
    TianGan(0) = "甲"
    TianGan(1) = "乙"
    TianGan(2) = "丙"
    TianGan(3) = "丁"
    TianGan(4) = "戊"
    TianGan(5) = "己"
    TianGan(6) = "庚"
    TianGan(7) = "辛"
    TianGan(8) = "壬"
    TianGan(9) = "癸"
    '地支名称
    DiZhi(0) = "子"
    DiZhi(1) = "丑"
    DiZhi(2) = "寅"
    DiZhi(3) = "卯"
    DiZhi(4) = "辰"
    DiZhi(5) = "巳"
    DiZhi(6) = "午"
    DiZhi(7) = "未"
    DiZhi(8) = "申"
    DiZhi(9) = "酉"
    DiZhi(10) = "戌"
    DiZhi(11) = "亥"
    '属相名称
    ShuXiang(0) = "鼠"
    ShuXiang(1) = "牛"
    ShuXiang(2) = "虎"
    ShuXiang(3) = "兔"
    ShuXiang(4) = "龙"
    ShuXiang(5) = "蛇"
    ShuXiang(6) = "马"
    ShuXiang(7) = "羊"
    ShuXiang(8) = "猴"
    ShuXiang(9) = "鸡"
    ShuXiang(10) = "狗"
    ShuXiang(11) = "猪"
    '农历日期名
    DayName(0) = "*"
    DayName(1) = "初一"
    DayName(2) = "初二"
    DayName(3) = "初三"
    DayName(4) = "初四"
    DayName(5) = "初五"
    DayName(6) = "初六"
    DayName(7) = "初七"
    DayName(8) = "初八"
    DayName(9) = "初九"
    DayName(10) = "初十"
    DayName(11) = "十一"
    DayName(12) = "十二"
    DayName(13) = "十三"
    DayName(14) = "十四"
    DayName(15) = "十五"
    DayName(16) = "十六"
    DayName(17) = "十七"
    DayName(18) = "十八"
    DayName(19) = "十九"
    DayName(20) = "二十"
    DayName(21) = "廿一"
    DayName(22) = "廿二"
    DayName(23) = "廿三"
    DayName(24) = "廿四"
    DayName(25) = "廿五"
    DayName(26) = "廿六"
    DayName(27) = "廿七"
    DayName(28) = "廿八"
    DayName(29) = "廿九"
    DayName(30) = "三十"
    '农历月份名
    MonName(0) = "*"
    MonName(1) = "正"
    MonName(2) = "二"
    MonName(3) = "三"
    MonName(4) = "四"
    MonName(5) = "五"
    MonName(6) = "六"
    MonName(7) = "七"
    MonName(8) = "八"
    MonName(9) = "九"
    MonName(10) = "十"
    MonName(11) = "十一"
    MonName(12) = "腊"
    '24节气名
    TermName(1) = "小寒"
    TermName(2) = "大寒"
    TermName(3) = "立春"
    TermName(4) = "雨水"
    TermName(5) = "惊蛰"
    TermName(6) = "春分"
    TermName(7) = "清明"
    TermName(8) = "谷雨"
    TermName(9) = "立夏"
    TermName(10) = "小满"
    TermName(11) = "芒种"
    TermName(12) = "夏至"
    TermName(13) = "小暑"
    TermName(14) = "大暑"
    TermName(15) = "立秋"
    TermName(16) = "处暑"
    TermName(17) = "白露"
    TermName(18) = "秋分"
    TermName(19) = "寒露"
    TermName(20) = "霜降"
    TermName(21) = "立冬"
    TermName(22) = "小雪"
    TermName(23) = "大雪"
    TermName(24) = "冬至"
    '农历主要节日
    Fday(1, 1) = "腊月三十"
    Fday(1, 2) = "除夕"
    Fday(2, 1) = "正月初一"
    Fday(2, 2) = "春节"
    Fday(3, 1) = "正月十五"
    Fday(3, 2) = "元宵"
    Fday(4, 1) = "五月初五"
    Fday(4, 2) = "端午"
    Fday(5, 1) = "七月初七"
    Fday(5, 2) = "七夕"
    Fday(6, 1) = "八月十五"
    Fday(6, 2) = "中秋"
    Fday(7, 1) = "九月初九"
    Fday(7, 2) = "重阳"
    '公历每月前面的天数
    MonthAdd(0) = 0
    MonthAdd(1) = 31
    MonthAdd(2) = 59
    MonthAdd(3) = 90
    MonthAdd(4) = 120
    MonthAdd(5) = 151
    MonthAdd(6) = 181
    MonthAdd(7) = 212
    MonthAdd(8) = 243
    MonthAdd(9) = 273
    MonthAdd(10) = 304
    MonthAdd(11) = 334
    '农历数据
    NongliData(0) = 2635
    NongliData(1) = 333387
    NongliData(2) = 1701
    NongliData(3) = 1748
    NongliData(4) = 267701
    NongliData(5) = 694
    NongliData(6) = 2391
    NongliData(7) = 133423
    NongliData(8) = 1175
    NongliData(9) = 396438
    NongliData(10) = 3402
    NongliData(11) = 3749
    NongliData(12) = 331177
    NongliData(13) = 1453
    NongliData(14) = 694
    NongliData(15) = 201326
    NongliData(16) = 2350
    NongliData(17) = 465197
    NongliData(18) = 3221
    NongliData(19) = 3402
    NongliData(20) = 400202
    NongliData(21) = 2901
    NongliData(22) = 1386
    NongliData(23) = 267611
    NongliData(24) = 605
    NongliData(25) = 2349
    NongliData(26) = 137515
    NongliData(27) = 2709
    NongliData(28) = 464533
    NongliData(29) = 1738
    NongliData(30) = 2901
    NongliData(31) = 330421
    NongliData(32) = 1242
    NongliData(33) = 2651
    NongliData(34) = 199255
    NongliData(35) = 1323
    NongliData(36) = 529706
    NongliData(37) = 3733
    NongliData(38) = 1706
    NongliData(39) = 398762
    NongliData(40) = 2741
    NongliData(41) = 1206
    NongliData(42) = 267438
    NongliData(43) = 2647
    NongliData(44) = 1318
    NongliData(45) = 204070
    NongliData(46) = 3477
    NongliData(47) = 461653
    NongliData(48) = 1386
    NongliData(49) = 2413
    NongliData(50) = 330077
    NongliData(51) = 1197
    NongliData(52) = 2637
    NongliData(53) = 268877
    NongliData(54) = 3365
    NongliData(55) = 531109
    NongliData(56) = 2900
    NongliData(57) = 2922
    NongliData(58) = 398042
    NongliData(59) = 2395
    NongliData(60) = 1179
    NongliData(61) = 267415
    NongliData(62) = 2635
    NongliData(63) = 661067
    NongliData(64) = 1701
    NongliData(65) = 1748
    NongliData(66) = 398772
    NongliData(67) = 2742
    NongliData(68) = 2391
    NongliData(69) = 330031
    NongliData(70) = 1175
    NongliData(71) = 1611
    NongliData(72) = 200010
    NongliData(73) = 3749
    NongliData(74) = 527717
    NongliData(75) = 1452
    NongliData(76) = 2742
    NongliData(77) = 332397
    NongliData(78) = 2350
    NongliData(79) = 3222
    NongliData(80) = 268949
    NongliData(81) = 3402
    NongliData(82) = 3493
    NongliData(83) = 133973
    NongliData(84) = 1386
    NongliData(85) = 464219
    NongliData(86) = 605
    NongliData(87) = 2349
    NongliData(88) = 334123
    NongliData(89) = 2709
    NongliData(90) = 2890
    NongliData(91) = 267946
    NongliData(92) = 2773
    NongliData(93) = 592565
    NongliData(94) = 1210
    NongliData(95) = 2651
    NongliData(96) = 395863
    NongliData(97) = 1323
    NongliData(98) = 2707
    NongliData(99) = 265877
    '生成当前公历年、月、日 ==> GongliStr
    curYear = Year(curTime)
    curMonth = Month(curTime)
    curDay = Day(curTime)
    GongliStr = curYear & "年"
    If (curMonth < 10) Then
        GongliStr = GongliStr & "0" & curMonth & "月"
    Else
        GongliStr = GongliStr & curMonth & "月"
    End If
    If (curDay < 10) Then
        GongliStr = GongliStr & "0" & curDay & "日"
    Else
        GongliStr = GongliStr & curDay & "日"
    End If
    '计算到初始时间1921年2月8日的天数：1921-2-8(正月初一)
    TheDate = (curYear - 1921) * 365 + Int((curYear - 1921) / 4) + curDay + MonthAdd(curMonth - 1) - 38
    If ((curYear Mod 4) = 0 And curMonth > 2) Then
        TheDate = TheDate + 1
    End If
    '计算农历天干、地支、月、日
    isEnd = 0
    m = 0
    Do
        If (NongliData(m) < 4095) Then
            k = 11
        Else
            k = 12
        End If
        n = k
        Do
            If (n < 0) Then
                Exit Do
            End If
            '获取NongliData(m)的第n个二进制位的值
            bit = NongliData(m)
            For i = 1 To n Step 1
                bit = Int(bit / 2)
            Next
            bit = bit Mod 2
            If (TheDate <= 29 + bit) Then
                isEnd = 1
                Exit Do
            End If
            TheDate = TheDate - 29 - bit
            n = n - 1
        Loop
        If (isEnd = 1) Then
            Exit Do
        End If
        m = m + 1
    Loop
    curYear = 1921 + m
    curMonth = k - n + 1
    curDay = TheDate
    If (k = 12) Then
        If (curMonth = (Int(NongliData(m) / 65536) + 1)) Then
            curMonth = 1 - curMonth
        ElseIf (curMonth > (Int(NongliData(m) / 65536) + 1)) Then
            curMonth = curMonth - 1
        End If
    End If
    '生成农历天干、地支、属相 ==> NongliStr
    NongliStr = TianGan(((curYear - 4) Mod 60) Mod 10) & DiZhi(((curYear - 4) Mod 60) Mod 12) & "年"
    NongliStr = NongliStr & "(" & ShuXiang(((curYear - 4) Mod 60) Mod 12) & ")"
    '生成农历月、日 ==> NongliDayStr
    If (curMonth < 1) Then
       NongliDayStr = MonName(-1 * curMonth)
    Else
        NongliDayStr = MonName(curMonth)
    End If
    NongliDayStr = NongliDayStr & "月"
    NongliDayStr = NongliDayStr & DayName(curDay)
    WDateToEDate = NongliStr & NongliDayStr
    '生成节气
    TmDate1 = CDate(Format((GetTerms(Year(curTime), Month(curTime) * 2 - 1)), "yyyy-mm-dd"))
    TmDate2 = CDate(Format((GetTerms(Year(curTime), Month(curTime) * 2)), "yyyy-mm-dd"))
    If CDate(curTime) = CDate(TmDate1) Then
        i = CLng(Month(curTime)) * 2 - 1
        WDateToEDate = WDateToEDate & " " & TermName(i)
    End If
    If CDate(curTime) = CDate(TmDate2) Then
        i = CLng(Month(curTime)) * 2
        WDateToEDate = WDateToEDate & " " & TermName(i)
    End If
    '生成农历节日
    For i = 1 To UBound(Fday, 1)
        If Fday(i, 1) = "" Then Exit For
        If InStr(WDateToEDate, Fday(i, 1)) > 0 Then
            WDateToEDate = WDateToEDate & " " & Fday(i, 2)
        End If
    Next
End Function

Public Function GetTerms(ByVal CurUnYear As Integer, ByVal iTerm As Integer) As Date
Dim offDate As Double
Dim vTermInfo As Variant
If iTerm > 24 Then Exit Function
'一个节气年的毫秒长度
Const sTermYearLen As Double = 31556925974.7
'求节气日期的定气常数（各个节气到小寒的分钟数）（如果能有人提供到秒的常数就好了）
vTermInfo = Array(0, 21208, 42467, 63836, 85337, 107014, 128867, 150921, _
             173149, 195551, 218072, 240693, 263343, 285989, 308563, 331033, _
             353350, 375494, 397447, 419210, 440795, 462224, 483532, 504758)
'节气日的时差公式(时差为分钟)(从1900年大寒到现在这一节气的的分钟数）
offDate = (sTermYearLen * (CurUnYear - 1900)) / 60000 + vTermInfo(iTerm - 1)
'以DateDiff求出日期
   GetTerms = DateAdd("n", offDate, CDate("1900-Jan-06 02:05:00"))
End Function

二、日历窗体

Private Sub 公历赋值()
Dim Pfname As String
Dim Sfname As String
Dim Cname As String
Dim Str As String
    If OpenArgs <> "" Then
        Str = OpenArgs
        Pfname = Mid(Str, 1, InStr(1, Str, ",") - 1)
        Str = Replace(Str, Pfname & ",", "")
        If InStr(1, Str, ",") = 0 Then
            Sfname = Pfname
            Cname = Str
            Forms(Sfname).Form.Controls(Cname).Value = Me.公历.Value
        Else
            Sfname = Mid(Str, 1, InStr(1, Str, ",") - 1)
            Str = Replace(Str, Sfname & ",", "")
            Cname = Str
            Forms(Pfname).Controls(Sfname).Form.Controls(Cname).Value = Me.公历.Value
        End If
        DoCmd.Close acForm, "日历"
    End If
End Sub
Private Sub 农历赋值()
Dim Pfname As String
Dim Sfname As String
Dim Cname As String
Dim Str As String
    If OpenArgs <> "" Then
        Str = OpenArgs
        Pfname = Mid(Str, 1, InStr(1, Str, ",") - 1)
        Str = Replace(Str, Pfname & ",", "")
        If InStr(1, Str, ",") = 0 Then
            Sfname = Pfname
            Cname = Str
            Forms(Sfname).Form.Controls(Cname).Value = Me.农历.Value
        Else
            Sfname = Mid(Str, 1, InStr(1, Str, ",") - 1)
            Str = Replace(Str, Sfname & ",", "")
            Cname = Str
            Forms(Pfname).Controls(Sfname).Form.Controls(Cname).Value = Me.农历.Value
        End If
        DoCmd.Close acForm, "日历"
    End If
End Sub

Private Sub 公历_DblClick(Cancel As Integer)
公历赋值
End Sub

Private Sub 农历_DblClick(Cancel As Integer)
    农历赋值
End Sub
Private Sub 格式()
For j = 1 To 6
    For i = 0 To 6
        If i = 0 Then
            Me.Controls("L" & i & j).ForeColor = Me.L日.ForeColor
            Else
            If i = 6 Then
                Me.Controls("L" & i & j).ForeColor = Me.L六.ForeColor
            Else
                Me.Controls("L" & i & j).ForeColor = RGB(0, 0, 0)
            End If
        End If
        Me.Controls("L" & i & j).BackColor = RGB(255, 255, 255)
        Me.Controls("L" & i & j).Caption = ""
        Me.Controls("L" & i & j).BackStyle = 0
        Me.Controls("L" & i & j).SpecialEffect = 5
    Next
Next
End Sub

Private Sub 生成()
Dim i As Long, j As Long
Dim Fday As Date, mydate As Date
格式
Fday = DateSerial(Format(Me.公历.Value, "yyyy"), Format(Me.公历.Value, "mm"), 1)        '本月第一天日期
mydate = Fday
For j = 1 To 6
    If j = 1 Then
        For i = Weekday(Fday) - 1 To 6
            Me.Controls("L" & i & j).Caption = Format(mydate, "d") & crlf & vbNewLine & Right(WDateToEDate(mydate), 2)
            If Format(mydate, "yymmdd") = Format(Me.公历.Value, "yymmdd") Then
                Me.Controls("L" & i & j).BackColor = RGB(0, 0, 255)
                Me.Controls("L" & i & j).ForeColor = RGB(255, 255, 255)
                Me.Controls("L" & i & j).SpecialEffect = 1
                Me.Controls("L" & i & j).BackStyle = 1
            End If
            mydate = DateAdd("d", 1, mydate)
        Next
    Else
        For i = 0 To 6
            If Month(mydate) <> Month(Fday) Then Exit For
            Me.Controls("L" & i & j).Caption = Format(mydate, "d") & crlf & vbNewLine & Right(WDateToEDate(mydate), 2)
            If Format(mydate, "yymmdd") = Format(Me.公历.Value, "yymmdd") Then
                Me.Controls("L" & i & j).BackColor = RGB(0, 0, 255)
                Me.Controls("L" & i & j).ForeColor = RGB(255, 255, 255)
                Me.Controls("L" & i & j).SpecialEffect = 1
                Me.Controls("L" & i & j).BackStyle = 1
                End If
            mydate = DateAdd("d", 1, mydate)
        Next
    End If
Next
End Sub

Private Sub Form_Open(Cancel As Integer)
生成
End Sub

Private Sub 年向后_Click()
Me.公历.Value = DateAdd("yyyy", 1, Me.公历.Value)
生成
End Sub

Private Sub 年向前_Click()
Me.公历.Value = DateAdd("yyyy", -1, Me.公历.Value)
生成
End Sub

Private Sub 月向后_Click()
Me.公历.Value = DateAdd("m", 1, Me.公历.Value)
生成
End Sub

Private Sub 月向前_Click()
    Me.公历.Value = DateAdd("m", -1, Me.公历.Value)
    生成
End Sub
Private Sub L01_Click()
    Me.公历.Value = DateSerial(Format(Me.公历.Value, "yyyy"), Format(Me.公历.Value, "mm"), Val(Me.L01.Caption))
    生成
End Sub

三、主窗体

Private Sub 日期_DblClick(Cancel As Integer)
    '请在OpenArgs参数中，用,号分割主窗体、子窗体控件、控件名称
    Dim Ctlname As String
    Ctlname = Screen.ActiveControl.Name
    DoCmd.OpenForm "日历", , , , , , Me.Form.Name & "," & Ctlname
End Sub

四、子窗体

Private Sub 公历日期_DblClick(Cancel As Integer)
    '请在OpenArgs参数中，用,号分割主窗体、子窗体控件、控件名称
    Dim Ctlname As String
    Ctlname = Screen.ActiveControl.Name
    DoCmd.OpenForm "日历", , , , , , Me.Parent.Form.Name & "," & Me.Form.Name & "," & Ctlname
End Sub

Private Sub 农历日期_DblClick(Cancel As Integer)
    '请在OpenArgs参数中，用,号分割主窗体、子窗体控件、控件名称
    Dim Ctlname As String
    Ctlname = Screen.ActiveControl.Name
    DoCmd.OpenForm "日历", , , , , , Me.Parent.Form.Name & "," & Me.Form.Name & "," & Ctlname
End Sub

Access软件网QQ交流群 (群号:483923997) 　　　　　　Access源码网店

【打印此文】【关闭窗口】