农历类(VB)

Public Class ClsChinaDay

    Private SolarMonth(12) As Integer '阳历12个月的天数
    Private SolarTerm(24) As String '阳历的节气
    Private sTermInfo(24) As Double '阳历节气的信息码
    Private LunarInfo(150) As Double '从1900-2049年这150年的农历信息码
    Private NewLunarInfo() As String

    Public Structure ChinaDateInfo
        Dim WestDate As String '西历
        Dim WeekDate As String '星期
        Dim ChinaDate As String '农历日期
        Dim Animal As String '属象
        Dim Term As String '节气
        Dim RestDay As String '节日
        Dim AllInfo As String '全部的信息
    End Structure

    Function BackChina(ByRef OldDate As String) As String
        '根据日期返回中文名称
        Dim NumberToChina(10) As String
        Dim CurYear As Integer
        Dim DayName(30) As String
        Dim MonName(12) As String
        Dim TianGan(10) As String
        Dim DiZhi(12) As String
        Dim StrTemp As String
        Dim II As Integer

        On Error Resume Next
        '中文数字
        NumberToChina(0) = "零"
        NumberToChina(1) = "一"
        NumberToChina(2) = "二"
        NumberToChina(3) = "三"
        NumberToChina(4) = "四"
        NumberToChina(5) = "五"
        NumberToChina(6) = "六"
        NumberToChina(7) = "七"
        NumberToChina(8) = "八"
        NumberToChina(9) = "九"
        '农历日期名
        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) = "腊"
        '天干名称
        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) = "亥"
        '例如：020480102
        CurYear = CInt(Mid(OldDate, 2, 4))
        BackChina = TianGan(((CurYear - 4) Mod 60) Mod 10) & DiZhi(((CurYear - 4) Mod 60) Mod 12) & "年"
        If Mid(OldDate, 1, 1) = "1" Then BackChina = BackChina & "闰"
        BackChina = BackChina & MonName(CInt(Mid(OldDate, 6, 2))) & "月"
        BackChina = BackChina & DayName(CInt(Mid(OldDate, 8, 12)))
    End Function

    '传回农历 y年m月的总天数
    Function lMonthDays(ByVal y As Integer, ByVal M As Integer) As Integer
        On Error Resume Next
        If y < 1900 Then y = 1900
        If (CDbl(LunarInfo(y - 1900 + 1)) And Int(&H10000 / (2 ^ M))) = 0 Then
            lMonthDays = 29
        Else
            lMonthDays = 30
        End If
    End Function

    '传回农历 y年闰哪个月 1-12 , 没闰传回 0
    Function LeapMonth(ByVal y As Integer) As Integer
        On Error Resume Next
        LeapMonth = 0
        If y >= 1900 Then LeapMonth = (LunarInfo(y - 1900 + 1) And &HFS)
    End Function

    '传回农历 y年闰月的天数
    Function LeapDays(ByVal y As Integer) As Integer
        On Error Resume Next
        Dim M As Integer
        Dim L As Double
        M = LeapMonth(y)
        If M = 0 Then
            LeapDays = 0
        Else
            L = LunarInfo(y - 1900 + 1)
            If L < 0 Then L = L * (-1)
            L = (L And &H10000)
            If L = 0 Then
                LeapDays = 29
            Else
                LeapDays = 30
            End If
        End If
    End Function

    '传回农历 y年的总天数
    Function lYearDays(ByVal y As Integer) As Integer
        Dim II, Sum As Double
        On Error Resume Next
        Sum = 0
        For II = 1 To 12
            Sum = Sum + lMonthDays(y, II)
        Next
        lYearDays = Sum + LeapDays(y)
    End Function

    '传回阳历 y年某m月的天数
    Function SolarDays(ByVal y As Integer, ByVal M As Integer) As Integer
        On Error Resume Next
        If M = 2 Then
            If (y Mod 4 = 0 And y Mod 100 <> 0) Or (y Mod 400 = 0) Then
                SolarDays = 29
            Else
                SolarDays = 28
            End If
        Else
            SolarDays = SolarMonth(M)
        End If
    End Function

    '根据年份返回属象
    Function Animal(ByVal sYear As Date) As String
        On Error Resume Next
        Dim ShuXiang(12) As String
        '属相名称
        ShuXiang(0) = "鼠"
        ShuXiang(1) = "牛"
        ShuXiang(2) = "虎"
        ShuXiang(3) = "兔"
        ShuXiang(4) = "龙"
        ShuXiang(5) = "蛇"
        ShuXiang(6) = "马"
        ShuXiang(7) = "羊"
        ShuXiang(8) = "猴"
        ShuXiang(9) = "鸡"
        ShuXiang(10) = "狗"
        ShuXiang(11) = "猪"
        Animal = ShuXiang(((Year(sYear) - 4) Mod 60) Mod 12)
    End Function

    '根据给定的阳历，返回农历的日期
    Function GetLunar(ByVal SolarDate As Date) As String
        Dim DaysOffset As Integer
        Dim II As Integer
        Dim Temp As Integer
        Dim lmonth, lyear, lday As Integer
        Dim Leap As Integer
        Dim IsLeap As Boolean

        On Error Resume Next

        DaysOffset = SolarDate.ToOADate - CDate("1900-1-31").ToOADate
        II = 1900
        Do While II < 2050 And DaysOffset >= 0
            Temp = lYearDays(II)
            DaysOffset = DaysOffset - Temp
            II = II + 1
        Loop

        If DaysOffset < 0 Then
            DaysOffset = DaysOffset + Temp
            II = II - 1
        End If
        lyear = II
        Leap = LeapMonth(II)
        IsLeap = False
        II = 1
        Do While II < 13 And DaysOffset > 0
            If Leap > 0 And II = (Leap + 1) And IsLeap = False Then
                II = II - 1
                IsLeap = True
                Temp = LeapDays(lyear)
            Else
                Temp = lMonthDays(lyear, II)
            End If
            If IsLeap And II = (Leap + 1) Then IsLeap = False
            DaysOffset = DaysOffset - Temp
            II = II + 1
        Loop

        If DaysOffset = 0 And Leap > 0 And II = Leap + 1 Then
            If IsLeap Then
                IsLeap = False
            Else
                IsLeap = True
                II = II - 1
            End If
        End If
        If DaysOffset < 0 Then
            DaysOffset = DaysOffset + Temp
            II = II - 1
        End If
        lmonth = II
        lday = DaysOffset + 1
        '返回特殊标志的字符串
        If IsLeap Then
            GetLunar = "1" & lyear & VB6.Format(lmonth, "00") & VB6.Format(lday, "00")
        Else
            GetLunar = "0" & lyear & VB6.Format(lmonth, "00") & VB6.Format(lday, "00")
        End If
    End Function

    '某y年的第n个节气的日期(从1小寒起算)
    Function sTerm(ByVal y As Object, ByRef n As Integer) As Date
        On Error Resume Next
        Dim D1, D2 As Double
        D1 = (31556925.9747 * (y - 1900) + sTermInfo(n) * 60.0#)
        D2 = DateDiff(Microsoft.VisualBasic.DateInterval.Second, CDate("1970-1-1 0:0"), CDate("1900-1-6 2:5")) + D1
        D1 = D2 / 2
        sTerm = DateAdd(Microsoft.VisualBasic.DateInterval.Second, D2 - D1, DateAdd(Microsoft.VisualBasic.DateInterval.Second, D1, CDate("1970-1-1 0:0")))
        sTerm = CDate(VB6.Format(sTerm, "yyyy/mm/dd"))
    End Function

    '根据阳历返回其节气，若不是则返回空
    Function GetTerm(ByVal sDate As Date) As String
        Dim y, M As Integer
        On Error Resume Next
        y = Year(sDate)
        M = Month(sDate)
        GetTerm = ""
        If sTerm(y, M * 2 - 1) = sDate Then
            GetTerm = SolarTerm(M * 2 - 1)
        ElseIf sTerm(y, M * 2) = sDate Then
            GetTerm = SolarTerm(M * 2)
        End If
    End Function

    '返回阳历是该月的第几个星期几的字符串，如:0520表示5月份第2个星期日
    Function GetMonthWeek(ByVal sDate As Date) As String
        Dim D0 As Date
        On Error Resume Next

        D0 = CDate(Year(sDate) & "-" & Month(sDate) & "-1")
        GetMonthWeek = VB6.Format(Month(sDate), "00") & (Int((Microsoft.VisualBasic.DateAndTime.Day(sDate) - 1 + Weekday(D0) - 1) / 7) + 1) & Weekday(sDate) - 1
    End Function

    Public Function GetChinaInfo(ByRef OldDate As Date) As ChinaDateInfo
        Dim II As Integer
        Dim StrTemp As String
        Dim StrDate As String
        Dim S1, S2 As String
        Dim sFtv(25) As String '阳历的节日
        Dim lFtv(11) As String '农历的节日
        Dim wFtv(11) As String '西方的节日
        On Error Resume Next
        '//时间超过2038年后就出现错误

        OldDate = CDate(VB6.Format(OldDate, "yyyy-mm-dd"))
        '阳历节日：前四位数字为阳历的MMDD（月日），后面的文字为意义
        sFtv(1) = "0101*元旦"
        sFtv(2) = "0214情人节"
        sFtv(3) = "0308妇女节"
        sFtv(4) = "0312植树节"
        sFtv(5) = "0315权益日"
        sFtv(6) = ""
        sFtv(7) = "0401愚人节"
        sFtv(8) = "0501*劳动节"
        sFtv(9) = "0504青年节"
        sFtv(10) = "0512护士节"
        sFtv(11) = "0601儿童节"
        sFtv(12) = "0701建党节"
        sFtv(13) = ""
        sFtv(14) = "0801建军节"
        sFtv(15) = "0808父亲节"
        sFtv(16) = "0909毛逝世纪念"
        sFtv(17) = "0910教师节"
        sFtv(18) = "0928孔子诞辰"
        sFtv(19) = "1001*国庆节"
        sFtv(20) = "1006老人节"
        sFtv(21) = "1024联合国日"
        sFtv(22) = "1112孙中山诞辰"
        sFtv(23) = "1220澳门回归"
        sFtv(24) = "1225圣诞节"
        sFtv(25) = "1226毛诞辰纪念"

        '农历的节日：日期表示的是农历的某月某日
        lFtv(1) = "0101*春节"
        lFtv(2) = "0115元宵节"
        lFtv(3) = "0505端午节"
        lFtv(4) = "0707七夕节"
        lFtv(5) = "0715中元节"
        lFtv(6) = "0815中秋节"
        lFtv(7) = "0909重阳节"
        lFtv(8) = ""
        lFtv(9) = "1208腊八节"
        lFtv(10) = "1224小年"
        lFtv(11) = "0100*除夕"

        '按星期计算的节日：如0231表示阳历02月份的第三个星期一
        wFtv(1) = ""
        wFtv(2) = "0231总统日"
        wFtv(3) = "0520母亲节"
        wFtv(4) = ""
        wFtv(5) = "0531胜利日"
        wFtv(6) = "0716合作节"
        wFtv(7) = "0730被奴周"
        wFtv(8) = ""
        wFtv(9) = ""
        wFtv(10) = "1021哥伦布日"
        wFtv(11) = "1144感恩节"
        '********************************

        NewLunarInfo = Split(Replace("0x04bd8,0x04ae0,0x0a570,0x054d5,0x0d260,0x0d950,0x16554,0x056a0,0x09ad0,0x055d2," & "0x04ae0,0x0a5b6,0x0a4d0,0x0d250,0x1d255,0x0b540,0x0d6a0,0x0ada2,0x095b0,0x14977," & "0x04970,0x0a4b0,0x0b4b5,0x06a50,0x06d40,0x1ab54,0x02b60,0x09570,0x052f2,0x04970," & "0x06566,0x0d4a0,0x0ea50,0x06e95,0x05ad0,0x02b60,0x186e3,0x092e0,0x1c8d7,0x0c950," & "0x0d4a0,0x1d8a6,0x0b550,0x056a0,0x1a5b4,0x025d0,0x092d0,0x0d2b2,0x0a950,0x0b557," & "0x06ca0,0x0b550,0x15355,0x04da0,0x0a5d0,0x14573,0x052d0,0x0a9a8,0x0e950,0x06aa0," & "0x0aea6,0x0ab50,0x04b60,0x0aae4,0x0a570,0x05260,0x0f263,0x0d950,0x05b57,0x056a0," & "0x096d0,0x04dd5,0x04ad0,0x0a4d0,0x0d4d4,0x0d250,0x0d558,0x0b540,0x0b5a0,0x195a6," & "0x095b0,0x049b0,0x0a974,0x0a4b0,0x0b27a,0x06a50,0x06d40,0x0af46,0x0ab60,0x09570," & "0x04af5,0x04970,0x064b0,0x074a3,0x0ea50,0x06b58,0x055c0,0x0ab60,0x096d5,0x092e0," & "0x0c960,0x0d954,0x0d4a0,0x0da50,0x07552,0x056a0,0x0abb7,0x025d0,0x092d0,0x0cab5," & "0x0a950,0x0b4a0,0x0baa4,0x0ad50,0x055d9,0x04ba0,0x0a5b0,0x15176,0x052b0,0x0a930," & "0x07954,0x06aa0,0x0ad50,0x05b52,0x04b60,0x0a6e6,0x0a4e0,0x0d260,0x0ea65,0x0d530," & "0x05aa0,0x076a3,0x096d0,0x04bd7,0x04ad0,0x0a4d0,0x1d0b6,0x0d250,0x0d520,0x0dd45," & "0x0b5a0,0x056d0,0x055b2,0x049b0,0x0a577,0x0a4b0,0x0aa50,0x1b255,0x06d20,0x0ada0", "0x", "&H"), ",")

        For II = 1 To 150
            LunarInfo(II) = CDbl(NewLunarInfo(II - 1)) '在字符处理的时候就已经转换成为十六进制乐
        Next

        For II = 1 To 12
            Select Case II
                Case 1, 3, 5, 7, 8, 10, 12
                    SolarMonth(II) = 31
                Case 2
                    SolarMonth(II) = 28
                Case Else
                    SolarMonth(II) = 30
            End Select
        Next

        S1 = "小寒大寒立春雨水惊蛰春分清明谷雨立夏小满芒种夏至小暑大暑立秋处暑白露秋分寒露霜降立冬小雪大雪冬至"
        S2 = "000000,021208,042467,063836,085337,107014,128867,150921,173149,195551,218072,240693,263343,285989,308563,331033,353350,375494,397447,419210,440795,462224,483532,504758"
        '对节气赋值
        For II = 1 To 24
            SolarTerm(II) = Mid(S1, (II - 1) * 2 + 1, 2)
            sTermInfo(II) = Val(Mid(S2, (II - 1) * 7 + 1, 6))
        Next

        '阳历节日
        StrDate = VB6.Format(OldDate, "mmdd")
        For II = 1 To UBound(sFtv)
            If sFtv(II) <> "" Then
                If Mid(sFtv(II), 1, 4) = StrDate Then '判断相等
                    StrTemp = Right(sFtv(II), Len(sFtv(II)) - 4)
                    Exit For
                End If
            End If
        Next
        '阴历节日
        StrDate = Right(GetLunar(CDate(OldDate)), 4)
        For II = 1 To UBound(lFtv)
            If lFtv(II) <> "" Then
                If Mid(lFtv(II), 1, 4) = StrDate Then '判断相等
                    If StrTemp <> "" Then StrTemp = StrTemp & ","
                    StrTemp = Right(lFtv(II), Len(lFtv(II)) - 4)
                End If
            End If
        Next
        '星期节日
        StrDate = GetMonthWeek(CDate(OldDate))
        For II = 1 To UBound(wFtv)
            If wFtv(II) <> "" Then
                If Mid(wFtv(II), 1, 4) = StrDate Then '判断相等
                    If StrTemp <> "" Then StrTemp = StrTemp & ","
                    StrTemp = Right(wFtv(II), Len(wFtv(II)) - 4)
                End If
            End If
        Next
        '取得信息
        GetChinaInfo.WestDate = VB6.Format(CDate(OldDate), "yyyy-mm-dd")
        GetChinaInfo.ChinaDate = BackChina(GetLunar(CDate(OldDate)))
        GetChinaInfo.Animal = Animal(OldDate)
        GetChinaInfo.Term = GetTerm(OldDate)
        GetChinaInfo.RestDay = StrTemp
        GetChinaInfo.WeekDate = WeekDayName(WeekDay(CDate(OldDate)))
        StrTemp = "今天是" & GetChinaInfo.WestDate & "(" & GetChinaInfo.WeekDate & "),农历" & GetChinaInfo.ChinaDate & "[" & GetChinaInfo.Animal & "]"
        If GetChinaInfo.RestDay <> "" Then StrTemp = StrTemp & "[" & GetChinaInfo.RestDay & "]"
        If GetChinaInfo.Term <> "" Then StrTemp = StrTemp & "[" & GetChinaInfo.Term & "]"
        GetChinaInfo.AllInfo = StrTemp
    End Function

End Class