CSDN博客

img 21aspnet

常用函数集农历函数

发表于2004/11/4 11:05:00  3868人阅读

分类: .NET C#字符串处理

常用函数集
农历函数

原来是vb代码,重新整理为VB.NET版的,并在VS2003中编译通过

Imports System.Math

Public Class UCnCalendar

    Private Structure SolarHolidayStruct
        Dim Month As Integer
        Dim Day As Integer
        Dim Recess As Integer
        Dim HolidayName As String
    End Structure

    Private Structure LunarHolidayStruct
        Dim Month As Integer
        Dim Day As Integer
        Dim Recess As Integer
        Dim HolidayName As String
    End Structure

    Private Structure WeekHolidayStruct
        Dim Month As Integer
        Dim WeekAtMonth As Integer
        Dim WeekDay As Integer
        Dim HolidayName As String
    End Structure

    '保持属性值的局部变量
    Private mvarSolarYear As Integer     '局部复制
    Private mvarSolarMonth As Integer     '局部复制
    Private mvarSolarDay As Integer        '局部复制
    Private mvarLunarYear As Integer     '局部复制
    Private mvarLunarMonth As Integer     '局部复制
    Private mvarLunarDay As Integer        '局部复制
    Private mvarIsLeap As Boolean     '局部复制

    Private mvarDate As Date            '内部使用标准的日期变量

    '定义类内部用公用变量
    Private SolarMonthObject As Object '每月最多天数

    Private mvarLunarGan As Object         '天干
    Private mvarLunarZhi As Object         '地支
    Private mvarLunarAnimals As Object     '生肖
    Private mvarLunarTerm As Object         '节气
    Private mvarLunarTermInfo As Object

    Private MonthName As Object         '英文月名
    Private LunarInfo(150) As Integer
    Private LunarYearDays(150) As Integer
    Private SolarHolidayInfo() As SolarHolidayStruct
    Private LunarHolidayInfo() As LunarHolidayStruct
    Private WeekHolidayInfo() As WeekHolidayStruct

    Private nStr1 As Object
    Private nStr2 As Object

    Public Sub New()
        'Dim tempArray As Object
        Dim i As Integer
        Dim b As Integer
        'Dim sFtv As Object
        'Dim lFtv As Object
        'Dim wFtv As Object

        '根据VB的位计算特点,故扩充原有的数据位,将其变成32位
        Dim tempArray() As Object = { _
             &H104BD8, &H104AE0, &H10A570, &H1054D5, &H10D260, &H10D950, &H116554, &H1056A0, &H109AD0, &H1055D2, _
             &H104AE0, &H10A5B6, &H10A4D0, &H10D250, &H11D255, &H10B540, &H10D6A0, &H10ADA2, &H1095B0, &H114977, _
             &H104970, &H10A4B0, &H10B4B5, &H106A50, &H106D40, &H11AB54, &H102B60, &H109570, &H1052F2, &H104970, _
             &H106566, &H10D4A0, &H10EA50, &H106E95, &H105AD0, &H102B60, &H1186E3, &H1092E0, &H11C8D7, &H10C950, _
             &H10D4A0, &H11D8A6, &H10B550, &H1056A0, &H11A5B4, &H1025D0, &H1092D0, &H10D2B2, &H10A950, &H10B557, _
             &H106CA0, &H10B550, &H115355, &H104DA0, &H10A5D0, &H114573, &H1052D0, &H10A9A8, &H10E950, &H106AA0, _
             &H10AEA6, &H10AB50, &H104B60, &H10AAE4, &H10A570, &H105260, &H10F263, &H10D950, &H105B57, &H1056A0, _
             &H1096D0, &H104DD5, &H104AD0, &H10A4D0, &H10D4D4, &H10D250, &H10D558, &H10B540, &H10B5A0, &H1195A6, _
             &H1095B0, &H1049B0, &H10A974, &H10A4B0, &H10B27A, &H106A50, &H106D40, &H10AF46, &H10AB60, &H109570, _
             &H104AF5, &H104970, &H1064B0, &H1074A3, &H10EA50, &H106B58, &H1055C0, &H10AB60, &H1096D5, &H1092E0, _
             &H10C960, &H10D954, &H10D4A0, &H10DA50, &H107552, &H1056A0, &H10ABB7, &H1025D0, &H1092D0, &H10CAB5, _
             &H10A950, &H10B4A0, &H10BAA4, &H10AD50, &H1055D9, &H104BA0, &H10A5B0, &H115176, &H1052B0, &H10A930, _
             &H107954, &H106AA0, &H10AD50, &H105B52, &H104B60, &H10A6E6, &H10A4E0, &H10D260, &H10EA65, &H10D530, _
             &H105AA0, &H1076A3, &H1096D0, &H104BD7, &H104AD0, &H10A4D0, &H11D0B6, &H10D250, &H10D520, &H10DD45, _
             &H10B5A0, &H1056D0, &H1055B2, &H1049B0, &H10A577, &H10A4B0, &H10AA50, &H11B255, &H106D20, &H10ADA0}

        For i = 0 To 149
            LunarInfo(i) = tempArray(i)
        Next

        tempArray = New Object() { _
                     384, 354, 355, 383, 354, 355, 384, 354, 355, 384, _
                     354, 384, 354, 354, 384, 354, 355, 384, 355, 384, _
                     354, 354, 384, 354, 354, 385, 354, 355, 384, 354, _
                     383, 354, 355, 384, 355, 354, 384, 354, 384, 354, _
                     354, 384, 355, 354, 385, 354, 354, 384, 354, 384, _
                     354, 355, 384, 354, 355, 384, 354, 383, 355, 354, _
                     384, 355, 354, 384, 355, 353, 384, 355, 384, 354, _
                     355, 384, 354, 354, 384, 354, 384, 354, 355, 384, _
                     355, 354, 384, 354, 384, 354, 354, 384, 355, 355, _
                     384, 354, 354, 383, 355, 384, 354, 355, 384, 354, _
                     354, 384, 354, 355, 384, 354, 385, 354, 354, 384, _
                     354, 354, 384, 355, 384, 354, 355, 384, 354, 354, _
                     384, 354, 355, 384, 354, 384, 354, 354, 384, 355, _
                     354, 384, 355, 384, 354, 354, 384, 354, 354, 384, _
                     355, 355, 384, 354, 384, 354, 354, 384, 354, 355}

        For i = 0 To 149
            LunarYearDays(i) = tempArray(i)
        Next

        SolarMonthObject = New Object() {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}
        mvarLunarGan = New Object() {"甲", "乙", "丙", "丁", "戊", "己", "庚", "辛", "壬", "癸"}
        mvarLunarZhi = New Object() {"子", "丑", "寅", "卯", "辰", "巳", "午", "未", "申", "酉", "戌", "亥"}
        mvarLunarAnimals = New Object() {"鼠", "牛", "虎", "兔", "龙", "蛇", "马", "羊", "猴", "鸡", "狗", "猪"}
        mvarLunarTerm = New Object() {"小寒", "大寒", "立春", "雨水", "惊蛰", "春分", "清明", "谷雨", "立夏", "小满", "芒种", "夏至", "小暑", "大暑", "立秋", "处暑", "白露", "秋分", "寒露", "霜降", "立冬", "小雪", "大雪", "冬至"}
        mvarLunarTermInfo = New Object() {0, 21208, 42467, 63836, 85337, 107014, 128867, 150921, 173149, 195551, 218072, 240693, 263343, 285989, 308563, 331033, 353350, 375494, 397447, 419210, 440795, 462224, 483532, 504758}
        nStr1 = New Object() {"日", "一", "二", "三", "四", "五", "六", "七", "八", "九", "十"}
        nStr2 = New Object() {"初", "十", "廿", "卅", " "}
        MonthName = New Object() {"JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC"}

        '国历节日 *表示放假日
        Dim sFtv() As Object = { _
             1, 1, 1, "元旦", _
             2, 14, 0, "情人节", _
             2, 10, 0, "国际气象节", _
             3, 18, 0, "妇女节", _
             3, 12, 0, "植树节", _
             3, 15, 0, "消费者权益日", _
             4, 1, 0, "愚人节", _
             5, 1, 1, "劳动节", _
             5, 4, 0, "青年节", _
             5, 12, 0, "护士节", _
             5, 31, 0, "世界无烟日", _
             6, 1, 1, "儿童节", _
             7, 1, 0, "建党节 香港回归纪念", _
             8, 1, 0, "建军节", _
             8, 8, 0, "中国男子节 父亲节", _
             9, 9, 0, "毛泽东逝世纪念", _
             9, 10, 0, "教师节", _
             9, 18, 0, "九·一八事变纪念日", _
             9, 28, 0, "孔子诞辰", _
             10, 1, 1, "国庆节 国际音乐日", _
             10, 6, 0, "老人节", _
             10, 24, 0, "联合国日", _
             11, 12, 0, "孙中山诞辰纪念", _
             12, 1, 0, "世界艾滋病日", _
             12, 3, 0, "世界残疾人日", _
             12, 20, 0, "澳门回归纪念", _
             12, 24, 0, "平安夜", _
             12, 25, 0, "圣诞节", _
             12, 26, 0, "毛泽东诞辰纪念"}

        b = UBound(sFtv) + 1
        ReDim SolarHolidayInfo(b / 4)
        For i = 0 To (b / 4) - 1
            SolarHolidayInfo(i).Month = sFtv(i * 4)
            SolarHolidayInfo(i).Day = sFtv(i * 4 + 1)
            SolarHolidayInfo(i).Recess = sFtv(i * 4 + 2)
            SolarHolidayInfo(i).HolidayName = sFtv(i * 4 + 3)
        Next

        '农历节日 *表示放假日
        Dim lFtv() As Object = { _
             1, 1, 1, "春节 弥勒佛圣诞", _
             1, 6, 0, "定光佛圣诞", _
             1, 15, 1, "元宵节", _
             2, 8, 0, "释迦牟尼佛出家", _
             2, 9, 0, "海空上师生日", _
             2, 15, 0, "释迦牟尼佛涅槃", _
             2, 19, 0, "观世音菩萨圣诞", _
             2, 21, 0, "普贤菩萨圣诞", _
             3, 4, 0, "清海上师圆寂日", _
             3, 16, 0, "准提菩萨圣诞", _
             4, 4, 0, "文殊菩萨圣诞 海空上师出家", _
             4, 8, 0, "释迦牟尼佛圣诞", _
             4, 15, 0, "佛吉祥日", _
             5, 5, 0, "端午节", _
             5, 13, 0, "伽蓝菩萨圣诞", _
             6, 3, 0, "护法韦驮尊天菩萨圣诞", _
             6, 19, 0, "观世音菩萨成道", _
             7, 7, 0, "七夕情人节", _
             7, 13, 0, "大势至菩萨圣诞", _
             7, 15, 0, "中秋节 盂兰盆节", _
             8, 22, 0, "燃灯佛圣诞", _
             7, 24, 0, "龙树菩萨圣诞", _
             7, 30, 0, "地藏菩萨圣诞", _
             8, 15, 0, "中秋节", _
             9, 9, 0, "重阳节", _
             9, 19, 0, "观世音菩萨出家纪念日", _
             9, 30, 0, "药师琉璃光如来圣诞", _
             10, 5, 0, "达摩祖师圣诞", _
             11, 7, 0, "阿弥陀佛圣诞", _
             12, 8, 0, "腊八节 释迦如来成道日", _
             12, 24, 0, "小年", _
             12, 29, 0, "华严菩萨圣诞"}
        '12, 31, 0, "除夕") '注意除夕需要其它方法进行计算

        b = UBound(lFtv) + 1
        ReDim LunarHolidayInfo(b / 4)
        For i = 0 To (b / 4) - 1
            LunarHolidayInfo(i).Month = lFtv(i * 4)
            LunarHolidayInfo(i).Day = lFtv(i * 4 + 1)
            LunarHolidayInfo(i).Recess = lFtv(i * 4 + 2)
            LunarHolidayInfo(i).HolidayName = lFtv(i * 4 + 3)
        Next

        '某月的第几个星期几
        Dim wFtv() As Object = { _
            5, 2, 1, "国际母亲节", _
            5, 3, 1, "全国助残日", _
            6, 3, 1, "父亲节", _
            9, 3, 3, "国际和平日", _
            9, 4, 1, "国际聋人节", _
            10, 1, 2, "国际住房日", _
            10, 1, 4, "国际减轻自然灾害日", _
            11, 4, 5, "感恩节"}

        b = UBound(wFtv) + 1
        ReDim WeekHolidayInfo(b / 4)
        For i = 0 To (b / 4) - 1
            WeekHolidayInfo(i).Month = wFtv(i * 4)
            WeekHolidayInfo(i).WeekAtMonth = wFtv(i * 4 + 1)
            WeekHolidayInfo(i).WeekDay = wFtv(i * 4 + 2) '1 代表星期天
            WeekHolidayInfo(i).HolidayName = wFtv(i * 4 + 3)
        Next
    End Sub

    '/////////////////////////////////////////////////////////////////////////////////////////////////////////////
    '计算农历上的节气
    ReadOnly Property LunarTerm() As String
        Get
            '//===== 某年的第n个节气为几日(从0小寒起算)
            'function sTerm(y,n) {
            ' var offDate = new Date( ( 31556925974.7*(y-1900) + LunarTermInfo[n]*60000 ) + Date.UTC(1900,0,6,2,5) )
            ' return(offDate.getUTCDate())
            '//节气
            ' tmp1 = sTerm(y, m * 2) - 1

            Dim baseDateAndTime As Date
            Dim newDate As Date
            Dim num As Double
            Dim y As Integer
            Dim tempStr As String

            baseDateAndTime = #1/6/1900 2:05:00 AM#
            y = mvarSolarYear
            tempStr = ""

            Dim i As Integer
            For i = 1 To 24
                num = 525948.76 * (y - 1900) + mvarLunarTermInfo(i - 1)
                newDate = DateAdd("n", num, baseDateAndTime) '按分钟计算,之所以不按秒钟计算,是因为会溢出
                If Abs(DateDiff("d", newDate, mvarDate)) = 0 Then
                    tempStr = mvarLunarTerm(i - 1)
                    Exit For
                End If
            Next

            LunarTerm = tempStr
        End Get
    End Property

    '计算按第几周星期几计算的节日
    ReadOnly Property WeekHoliday() As String
        Get
            Dim w As Integer
            Dim i As Integer
            Dim b As Integer
            Dim FirstDay As Date
            Dim tempStr As String

            b = UBound(WeekHolidayInfo)
            For i = 0 To b
                If WeekHolidayInfo(i).Month = mvarSolarMonth Then '当月份相当时
                    w = Weekday(mvarDate)
                    If WeekHolidayInfo(i).WeekDay = w Then '仅当星期几也相等时
                        FirstDay = mvarSolarMonth & "/" & 1 & "/" & mvarSolarYear '取当月第一天
                        If (DateDiff("ww", FirstDay, mvarDate) = WeekHolidayInfo(i).WeekAtMonth) Then
                            tempStr = WeekHolidayInfo(i).HolidayName
                        End If
                    End If
                End If
            Next


            WeekHoliday = tempStr
        End Get
    End Property

    ReadOnly Property LunarHoliday() As String
        Get
            Dim i As Integer
            Dim b As Integer
            Dim tempStr As String
            Dim oy As Integer
            Dim odate As Date
            Dim ndate As Date

            tempStr = ""
            b = UBound(LunarHolidayInfo)
            If mvarLunarMonth = 12 And (mvarLunarDay = 29 Or mvarLunarDay = 30) Then

                oy = mvarLunarYear '保存农历年数
                odate = mvarDate
                ndate = mvarDate.AddDays(1)
                Call SolarInitDate(Year(ndate), Month(ndate), Microsoft.VisualBasic.DateAndTime.Day(ndate)) '计算第二天的属性
                If oy = mvarLunarYear - 1 Then '如果农历年数增加了1
                    tempStr = "除夕"
                    Call SolarInitDate(Year(odate), Month(odate), Microsoft.VisualBasic.DateAndTime.Day(odate)) '恢复到今天原有数据

                End If
            Else
                For i = 0 To b
                    If (LunarHolidayInfo(i).Month = mvarLunarMonth) And _
                     (LunarHolidayInfo(i).Day = mvarLunarDay) Then
                        tempStr = LunarHolidayInfo(i).HolidayName
                        Exit For
                    End If
                Next
            End If
            LunarHoliday = tempStr
        End Get
    End Property

    '求公历节日
    ReadOnly Property SolarHoliday() As String
        Get
            Dim i As Integer
            Dim b As Integer
            Dim tempStr As String

            tempStr = ""
            b = UBound(SolarHolidayInfo)
            For i = 0 To b
                If (SolarHolidayInfo(i).Month = mvarSolarMonth) And _
                 (SolarHolidayInfo(i).Day = mvarSolarDay) Then
                    tempStr = SolarHolidayInfo(i).HolidayName
                    Exit For
                End If
            Next
            SolarHoliday = tempStr
        End Get
    End Property

    '是否是农历的闰月
    ReadOnly Property IsLeap() As Boolean
        Get
            IsLeap = mvarIsLeap
        End Get
    End Property

    ReadOnly Property LunarDay() As Integer
        Get
            LunarDay = mvarLunarDay
        End Get
    End Property

    ReadOnly Property LunarMonth() As Integer
        Get
            LunarMonth = mvarLunarMonth
        End Get
    End Property

    ReadOnly Property LunarYear() As Integer
        Get
            LunarYear = mvarLunarYear
        End Get
    End Property

    ReadOnly Property SolarWeekDay() As Integer
        Get
            SolarWeekDay = Weekday(mvarDate)
        End Get
    End Property

    ReadOnly Property SolarDay() As Integer
        Get
            SolarDay = mvarSolarDay
        End Get
    End Property

    ReadOnly Property SolarMonth() As Integer
        Get
            SolarMonth = mvarSolarMonth
        End Get
    End Property

    ReadOnly Property SolarYear() As Integer
        Get
            SolarYear = mvarSolarYear
        End Get
    End Property

    '////////////////////////////////////////////////////////////////////////////////////////////////////////
    Public Function IsToday(ByVal y As Integer, ByVal m As Integer, ByVal d As Integer) As Boolean

        If (Year(Today) = y) And _
         (Month(Today) = m) And _
         (Microsoft.VisualBasic.DateAndTime.Day(Today) = d) Then
            IsToday = True
        Else
            IsToday = False
        End If

    End Function

    '根据年份不同计算当年属于什么朝代
    Public Function CNEra(ByVal y As Integer) As String
        Dim tempStr As String

        If y < 1874 Then
            tempStr = "未知"
        Else
            If y <= 1908 Then
                tempStr = "清朝光绪"
                If y = 1874 Then
                    tempStr = tempStr & "元年"
                Else
                    tempStr = tempStr & CNNumber(CStr(y - 1874)) & "年"
                End If
            Else
                If y <= 1910 Then
                    tempStr = "清朝宣统"
                    If y = 1909 Then
                        tempStr = tempStr & "元年"
                    Else
                        tempStr = tempStr & CNNumber(CStr(y - 1909 + 1)) & "年"
                    End If
                Else
                    If y < 1949 Then
                        tempStr = "中华民国"
                        If y = 1912 Then
                            tempStr = tempStr & "元年"
                        Else
                            tempStr = tempStr & CNNumber(CStr(y - 1912 + 1)) & "年"
                        End If
                    Else
                        tempStr = "中华人民共和国成立"
                        If y = 1949 Then
                            tempStr = tempStr & "了"
                        Else
                            Select Case y
                                Case 2000
                                    tempStr = "千禧年"
                                Case Else
                                    tempStr = tempStr & CNNumber(CStr(y - 1949)) & "周年"
                            End Select
                        End If
                    End If
                End If
            End If
        End If

        CNEra = tempStr
    End Function

    ' 传入 num 传回干支, 0=甲子
    Public Function LunarGanZhi(ByVal num As Integer) As String
        Dim tempStr As String
        Dim i As Integer
        i = (num - 1864) Mod 60 '计算干支
        tempStr = mvarLunarGan(i Mod 10) & mvarLunarZhi(i Mod 12)
        LunarGanZhi = tempStr
    End Function

    '计算年的属相字串
    Public Function YearAttribute(ByVal y As Integer) As String
        YearAttribute = mvarLunarAnimals((y - 1900) Mod 12)
    End Function

    '将数字汉化
    Public Function CNNumber(ByVal Dxs As String) As String
        '检测为空时
        If Trim(Dxs) = "" Then
            CNNumber = ""
            Exit Function
        End If

        Dim Sw As Integer, SzUp As Integer, tempStr As String, DXStr As String
        Sw = Len(Trim(Dxs))

        Dim i As Integer
        For i = 1 To Sw
            tempStr = Right(Trim(Dxs), i)
            tempStr = Left(tempStr, 1)
            tempStr = Converts(tempStr)
            Select Case i
                Case 1
                    If tempStr = "零" Then
                        tempStr = ""
                    Else
                        tempStr = tempStr + ""
                    End If
                Case 2
                    If tempStr = "零" Then
                        tempStr = "零"
                    Else
                        tempStr = tempStr + "十"
                    End If
                Case 3
                    If tempStr = "零" Then
                        tempStr = "零"
                    Else
                        tempStr = tempStr + "百"
                    End If
                Case 4
                    If tempStr = "零" Then
                        tempStr = "零"
                    Else
                        tempStr = tempStr + "千"
                    End If
                Case 5
                    If tempStr = "零" Then
                        tempStr = "万"
                    Else
                        tempStr = tempStr + "万"
                    End If
                Case 6
                    If tempStr = "零" Then
                        tempStr = "零"
                    Else
                        tempStr = tempStr + "十"
                    End If
                Case 7
                    If tempStr = "零" Then
                        tempStr = "零"
                    Else
                        tempStr = tempStr + "百"
                    End If
                Case 8
                    If tempStr = "零" Then
                        tempStr = "零"
                    Else
                        tempStr = tempStr + "千"
                    End If
                Case 9
                    If tempStr = "零" Then
                        tempStr = "亿"
                    Else
                        tempStr = tempStr + "亿"
                    End If
            End Select
            Dim TempA As String
            TempA = Left(Trim(DXStr), 1)
            If tempStr = "零" Then
                Select Case TempA
                    Case "零"
                        DXStr = DXStr
                    Case "万"
                        DXStr = DXStr
                    Case "亿"
                        DXStr = DXStr
                    Case Else
                        DXStr = tempStr + DXStr
                End Select
            Else
                DXStr = tempStr + DXStr
            End If
        Next

        CNNumber = DXStr
    End Function

    Private Function Converts(ByVal NumStr As String) As String
        Select Case Val(NumStr)
            Case 0
                Converts = "零"
            Case 1
                Converts = "一"
            Case 2
                Converts = "二"
            Case 3
                Converts = "三"
            Case 4
                Converts = "四"
            Case 5
                Converts = "五"
            Case 6
                Converts = "六"
            Case 7
                Converts = "七"
            Case 8
                Converts = "八"
            Case 9
                Converts = "九"
        End Select
    End Function

    '中文日期
    Public Function CNDayStr(ByVal d As Integer) As String
        Dim s As String
        Select Case d
            Case 0
                s = ""
            Case 10
                s = "初十"
            Case 20
                s = "二十"
            Case 30
                s = "三十"
            Case Else
                s = nStr2(d / 10) '整数除法
                s = s & nStr1(d Mod 10)
        End Select
        CNDayStr = s
    End Function

    '中文月份
    Public Function CNMonthStr(ByVal d As Integer) As String
        If d < 10 Then
            CNMonthStr = Converts(d Mod 10)
        ElseIf d = 10 Then
            CNMonthStr = "十"
        Else
            CNMonthStr = "十" & Converts(d Mod 10)
        End If
    End Function

    '中文年份
    Public Function CNYearStr(ByVal d As Integer) As String
        Dim i As Integer
        CNYearStr = ""
        Dim l As Integer = Len(d.ToString)

        For i = 1 To l
            CNYearStr &= Converts(Mid(d.ToString, i, 1))
        Next
    End Function

    '中文星期
    Public Function CNWeekDayStr()
        Dim arrWeek() As Object = {"一", "日", "一", "二", "三", "四", "五", "六"}
        CNWeekDayStr = "星期" & arrWeek(Weekday(mvarDate))
    End Function

    '计算星座归属
    Public Function Constellation(ByVal m As Integer, ByVal d As Integer) As String
        Dim y As Integer
        Dim tempDate As Date
        Dim ConstellName As String

        y = 2000
        tempDate = m & "/" & d & "/" & y
        Select Case tempDate
            Case #3/21/2000# To #4/19/2000#
                ConstellName = "白羊"
            Case #4/20/2000# To #5/20/2000#
                ConstellName = "金牛"
            Case #5/21/2000# To #6/21/2000#
                ConstellName = "双子"
            Case #6/22/2000# To #7/22/2000#
                ConstellName = "巨蟹"
            Case #7/23/2000# To #8/22/2000#
                ConstellName = "狮子"
            Case #8/23/2000# To #9/22/2000#
                ConstellName = "处女"
            Case #9/23/2000# To #10/23/2000#
                ConstellName = "天秤"
            Case #10/24/2000# To #11/21/2000#
                ConstellName = "天蝎"
            Case #11/22/2000# To #12/21/2000#
                ConstellName = "射手"
            Case #12/22/2000# To #12/31/2000#
                ConstellName = "摩蝎"
            Case #1/1/2000# To #1/19/2000#
                ConstellName = "摩蝎"
            Case #1/20/2000# To #2/18/2000#
                ConstellName = "水瓶"
            Case #2/19/2000# To #3/20/2000#
                ConstellName = "双鱼"
            Case Else
                ConstellName = ""
        End Select
        Constellation = ConstellName
    End Function

    '/////////////////////////////////////////////////////////////////////////////////////////////////////////
    '以下为类内部使用的一些函数
    '传回农历 y年的总天数
    Private Function lYearDays(ByVal y As Integer) As Integer

        ' Dim i As Integer
        ' Dim f As Integer
        ' Dim sumDay As Integer
        ' Dim info As Integer

        ' sumDay = 348
        ' i = &H8000
        ' info = LunarInfo(y - 1900) And &H1000FFFF '屏蔽高位,
        ' Do
        '     f = info And i
        '     If f <> 0 Then
        '     sumDay = sumDay + 1
        '     End If
        '     i = BitRight16(i, 1)
        ' Loop Until i < &H10
        ' lYearDays = sumDay + leapDays(y)

        lYearDays = LunarYearDays(y - 1900) '先计算出每年的天数,并形成数组,以减少以后的运算时间
    End Function

    '传回农历 y年m月的总天数
    Private Function lMonthDays(ByVal y As Integer, ByVal m As Integer) As Integer
        If (LunarInfo(y - 1900) And &H1000FFFF) And (&H10000 >> m) Then
            lMonthDays = 30
        Else
            lMonthDays = 29
        End If
    End Function

    '传回农历 y年闰月的天数
    Private Function leapDays(ByVal y As Integer) As Integer
        If leapMonth(y) Then
            If LunarInfo(y - 1900) And &H10000 Then
                leapDays = 30
            Else
                leapDays = 29
            End If
        Else
            leapDays = 0
        End If
    End Function

    '传回农历 y年闰哪个月 1-12 , 没闰传回 0
    Private Function leapMonth(ByVal y As Integer) As Integer
        Dim i As Integer
        i = LunarInfo(y - 1900) And &HF
        If i > 12 Then

        End If
        leapMonth = i
    End Function

    '计算公历年月的天数
    Private Function SolarDays(ByVal y As Integer, ByVal m As Integer) As Integer
        Dim d As Integer

        If (y Mod 4) = 0 Then '闰年
            If m = 2 Then
                d = 29
            Else
                d = SolarMonthObject(m - 1)
            End If
        Else
            If m = 2 Then
                d = 28
            Else
                d = SolarMonthObject(m - 1)
            End If
        End If

        SolarDays = d
    End Function

    '//////////////////////////////////////////////////////////////////////////////////////////////////
    '
    '主要的函数,用公历年月日对日期对象进行初使化,在此函数内部完成对私有对象属性的设置
    '
    '//////////////////////////////////////////////////////////////////////////////////////////////////
    Public Sub SolarInitDate(ByVal y As Integer, ByVal m As Integer, ByVal d As Integer)
        Dim i As Integer
        Dim leap As Integer
        Dim Temp As Integer
        Dim offset As Integer

        mvarDate = New Date(y, m, d)
        mvarSolarYear = y
        mvarSolarMonth = m
        mvarSolarDay = d

        '农历日期计算部分
        leap = 0
        Temp = 0

        offset = mvarDate.Subtract(New System.DateTime(1900, 1, 30)).Days '计算两天的基本差距

        For i = 1900 To 2049
            Temp = lYearDays(i) '求当年农历年天数

            offset = offset - Temp
            If offset < 1 Then Exit For
        Next

        offset = offset + Temp
        mvarLunarYear = i

        leap = leapMonth(i) '闰哪个月
        mvarIsLeap = False
        For i = 1 To 12
            '闰月
            If leap > 0 And i = (leap + 1) And mvarIsLeap = False Then
                mvarIsLeap = True
                i = i - 1
                Temp = leapDays(mvarLunarYear) '计算闰月天数
            Else
                Temp = lMonthDays(mvarLunarYear, i) '计算非闰月天数
            End If

            offset = offset - Temp
            If offset <= 0 Then Exit For
        Next

        offset = offset + Temp
        mvarLunarMonth = i
        mvarLunarDay = offset
    End Sub

    '//////////////////////////////////////////////////////////////////////////////////////////////////
    '
    '主要的函数,用农历年月日对日期对象进行初使化,在此函数内部完成对私有对象属性的设置
    '
    '//////////////////////////////////////////////////////////////////////////////////////////////////
    Public Sub LunarInitDate(ByVal y As Integer, ByVal m As Integer, ByVal d As Integer, Optional ByVal LeapFlag As Boolean = False)
        Dim i As Integer
        Dim leap As Integer
        Dim Temp As Integer
        Dim offset As Integer
        mvarLunarYear = y
        mvarLunarMonth = m
        mvarLunarDay = d

        offset = 0

        For i = 1900 To y - 1
            Temp = LunarYearDays(i - 1900) '求当年农历年天数
            offset = offset + Temp
        Next

        leap = leapMonth(y) '闰哪个月
        If m <> leap Then
            mvarIsLeap = False '当前日期并非闰月
        Else
            mvarIsLeap = LeapFlag '使用用户输入的是否闰月月份
        End If

        If (m < leap) Or (leap = 0) Then '当闰月在当前日期后
            For i = 1 To m - 1
                Temp = lMonthDays(y, i) '计算非闰月天数
                offset = offset + Temp
            Next
        Else '在闰月后
            If mvarIsLeap = False Then '用户要计算非闰月的月份
                For i = 1 To m - 1
                    Temp = lMonthDays(y, i) '计算非闰月天数
                    offset = offset + Temp
                Next
                If m > leap Then
                    Temp = leapDays(y) '计算闰月天数
                    offset = offset + Temp
                End If

            Else '此时只有mvarisleap=ture,
                For i = 1 To m
                    Temp = lMonthDays(y, i) '计算非闰月天数
                    offset = offset + Temp
                Next
            End If
        End If

        offset = offset + d '加上当月的天数
        mvarDate = DateAdd("d", offset, #1/30/1900#)
        mvarSolarYear = Year(mvarDate)
        mvarSolarMonth = Month(mvarDate)
        mvarSolarDay = Microsoft.VisualBasic.DateAndTime.Day(mvarDate)
    End Sub

    '本模块用于打印出1900-2049年 每年农历的天数,可以用于数组初使化
    'Public Sub printf()
    '    Dim i As Integer, j As Integer
    '    Dim temp(10) As Integer
    '    Dim base As Integer

    '    base = 1900
    '    For i = 1 To 15
    '     For j = 1 To 10
    '         temp(j - 1) = lYearDays((i - 1) * 10 + (j - 1) + base) '求当年农历年天数
    '     Next
    '     Debug.Print CStr(temp(0)) & " , " & CStr(temp(1)) & " , " & CStr(temp(2)) & " , " & CStr(temp(3)) & " , " & CStr(temp(4)) & " , " & CStr(temp(5)) & " , " & CStr(temp(6)) & " , " & CStr(temp(7)) & " , " & CStr(temp(8)) & " , " & CStr(temp(9)) & " , " & " _ "
    '    Next
    'End Sub


End Class

阅读全文
0 0

相关文章推荐

img
取 消
img