[修改]公历转农历

'1901～2100
 
 
 
Private Const ylData = "010010111101080131,010010101110000219,101001010111000208,010101001101050129,110100100110000216,110110010101000204,011001010101140125,010101101010000213,100110101101000202,010101011101020122," & _
 
                           "010010101110000210,101001011011060130,101001001101000218,110100100101000206,110100100101150126,101101010101000214,010101101010000204,101011011010020123,100101011011000211,010010010111170201," & _
 
                           "010010011011000220,101001001011000208,101101001011050128,011010100101000216,011011010100000205,101010110101140124,001010110110000213,100101010111000202,010100101111020123,010010010111000210," & _
 
                           "011001010110060130,110101001010000217,111010100101000206,011010101001150126,010110101101000214,001010110110000204,100001101110130124,100100101110000211,110010001101170131,110010010101000219," & _
 
                           "110101001010000208,110110001010160127,101101010101000215,010101101010000205,101001011011140125,001001011101000213,100100101101000202,110100101011020122,101010010101000210,101101010101070129," & _
 
                           "011011001010000217,101101010101000206,010100110101150127,010011011010000214,101001011011000203,010001010111130124,010100101011000212,101010011010080131,111010010101000218,011010101010000208," & _
 
                           "101011101010060128,101010110101000215,010010110110000205,101010101110040125,101001010111000213,010100100110000202,111100100110030121,110110010101000209,010110110101070130,010101101010000217," & _
 
                           "100101101101000206,010011011101050127,010010101101000215,101001001101000203,110101001101040123,110100100101000211,110101010101080131,101101010100000218,101101101010000207,100101011010160128," & _
 
                           "100101011011000216,010010011011000205,101010010111040125,101001001011000213,1011001001110A0202,011010100101000220,011011010100000209,101011110100060129,101010110110000217,100101010111000206," & _
 
                           "010010101111050127,010010010111000215,011001001011000204,011101001010030123,111010100101000210,011010110101080131,010110101100000219,101010110110000207,100101101101050128,100100101110000216," & _
 
                           "110010010110000205,110110010101040124,110101001010000212,110110100101000201,011101010101020122,010101101010000209,101010111011070129,001001011101000218,100100101101000207,110010101011050126," & _
 
                           "101010010101000214,101101001010000203,101110101010040123,101011010101000210,010101011101090131,010010111010000219,101001011011000208,010100010111160128,010100101011000216,101010010011000205," & _
 
                           "011110010101040125,011010101010000212,101011010101000201,010110110101020122,010010110110000210,100101101110060129,101001001110000217,110100100110000206,111010100110050126,110101010011000213," & _
 
                           "010110101010000203,011101101010030123,100101101101000211,0100101010110B0131,010010101101000219,101001001101000208,110100001011160128,110100100101000215,110101010010000204,110111010100050124," & _
 
                           "101101011010000212,010101101101000201,010101011011020122,010010011011000210,101001010111070130,101001001011000217,101010100101000206,101100100101150126,011011010010000214,101011011010000202," & _
 
                           "010010110110130123,100100110111000211,010010011111080201,010010010111000219,011001001011000208,011010001010160128,111010100101000215,011010101010000204,101001101100140124,101010101110000212," & _
 
                           "100100101110000202,110100101110030121,110010010110000209,110101010101070129,110101001010000217,110110100100000205,010111010101050126,010101101010000214,101001101100000203,010101011101040123," & _
 
                           "010100101101000211,101010011011080131,101010010101000219,101101001010000207,101101101010060127,101011010101000215,010101011010000205,101010111010040124,101001011010000212,010100101011000202," & _
 
                           "101100100111030122,011010010011000209,011100110011070129,011010101010000217,101011010101000206,010010110101150126,010010110110000214,101001010111000203,010101001110040124,110100010110000210," & _
 
                           "111010010110080130,110101010010000218,110110101010000207,011010101010160127,010101101101000215,010010101110000205,101010011101040125,101000101101000212,110100010101000201,111100100101020121,110101010010000209"
 
 
 
    Private Const ylMd0 = "初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十 "
 
    Private Const ylMn0 = "正二三四五六七八九十冬腊"
 
    Private Const ylTianGan0 = "甲乙丙丁戊己庚辛壬癸"
 
    Private Const ylDiZhi0 = "子丑寅卯辰巳午未申酉戌亥"
 
    Private Const ylShu0 = "鼠牛虎兔龙蛇马羊猴鸡狗猪"
 
 
 
    '公历日期转农历
 
    Function GetNLDate(ByVal strDate As String) As String
 
        If Not IsDate(strDate) Then Return ""
 
        Dim setDate As Date
 
        Dim tYear, tMonth, tDay As Integer
 
        '
 
        setDate = CDate(strDate)
 
        tYear = Year(setDate) : tMonth = Month(setDate) : tDay = CDate(setDate).ToString("dd")
 
 
 
        '超出范围
 
        If tYear > 2100 OrElse tYear < 1901 Then Return ""
 
        '
 
        Dim daList(1) As String
 
        Dim conDate As Date
 
        Dim thisMonths As String
 
        Dim AddYear, AddMonth, AddDay, getDay, RunYue1, mDays, i, j As Integer
 
        Dim YLyear, YLShuXing As String
 
        Dim dd0, mm0 As String
 
        Dim ganzhi(59) As String
 
        Dim RunYue As Boolean
 
        Try
 
            '加载2年内的农历数据
 
            daList(0) = ylData.Substring((tYear - 1900 - 1) * 19, 18)
 
            daList(1) = ylData.Substring((tYear - 1900) * 19, 18)
 
            AddYear = tYear
 
            j = 1
 
            While True
 
                AddMonth = CInt(Mid(daList(j), 15, 2))
 
                AddDay = CInt(Mid(daList(j), 17, 2))
 
                conDate = DateSerial(AddYear, AddMonth, AddDay) '农历新年日期
 
                getDay = DateDiff(DateInterval.Day, conDate, setDate) + 1 '相差天数
 
                If getDay > 0 Then Exit While
 
                AddYear -= 1
 
                j -= 1
 
            End While
 
            thisMonths = Left(daList(j), 14)
 
            RunYue1 = Val("&H" & Right(thisMonths, 1))           '闰月月份
 
            If RunYue1 > 0 Then                                  '有闰月
 
                thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)
 
            End If
 
            thisMonths = Left(thisMonths, 13)
 
            For i = 1 To 13                                      '计算天数
 
                mDays = 29 + CInt(Mid(thisMonths, i, 1))
 
                If getDay > mDays Then
 
                    getDay = getDay - mDays
 
                Else
 
                    If RunYue1 > 0 Then
 
                        If i = RunYue1 + 1 Then RunYue = True
 
                        If i > RunYue1 Then i = i - 1
 
                    End If
 
                    AddMonth = i
 
                    AddDay = getDay
 
                    Exit For
 
                End If
 
            Next
 
            dd0 = Mid(ylMd0, (AddDay - 1) * 2 + 1, 2)
 
            mm0 = Mid(ylMn0, AddMonth, 1) + "月"
 
            For i = 0 To 59
 
                ganzhi(i) = Mid(ylTianGan0, (i Mod 10) + 1, 1) + Mid(ylDiZhi0, (i Mod 12) + 1, 1)
 
            Next
 
            YLyear = ganzhi((AddYear - 4) Mod 60)
 
            YLShuXing = Mid(ylShu0, ((AddYear - 4) Mod 12) + 1, 1)
 
            If RunYue Then mm0 = "闰" & mm0
 
        Catch ex As Exception
 
            Return ""
 
        End Try
 
        Return "农历:" & YLyear & "(" & YLShuXing & ")年" & mm0 & dd0
 
    End Function