请高手分享一段VBA阳历转农历的自定义函数代码！

Fangfangyy

最近需要用到阳历转农历，有查看过一些大师设计的转换器，但是他们设置了工程不可查看，只可以用。因此烦请高人分享一下VBA源代码，最好是自定义函数形式的，不胜感激！

wudixin96

公历转农历模块（vba）摘录

'公历转农历模块
'原创：互联网
'修正：阿勇 2005/1/12

'// 农历数据定义 //
'先以 H2B 函数还原成长度为 18 的字符串，其定义如下：
'前12个字节代表1-12月：1为大月，0为小月；压缩成十六进制(1-3位)
'第13位为闰月的情况，1为大月30天，0为小月29天；(4位)
'第14位为闰月的月份，如果不是闰月为0，否则给出月份(5位)
'最后4位为当年农历新年的公历日期，如0131代表1月31日；当作数值转十六进制(6-7位)

'农历常量(1899~2100，共202年）
Private Const ylData = "AB500D2,4BD0883," _
        & "4AE00DB,A5700D0,54D0581,D2600D8,D9500CC,655147D,56A00D5,9AD00CA,55D027A,4AE00D2," _
        & "A5B0682,A4D00DA,D2500CE,D25157E,B5500D6,56A00CC,ADA027B,95B00D3,49717C9,49B00DC," _
        & "A4B00D0,B4B0580,6A500D8,6D400CD,AB5147C,2B600D5,95700CA,52F027B,49700D2,6560682," _
        & "D4A00D9,EA500CE,6A9157E,5AD00D6,2B600CC,86E137C,92E00D3,C8D1783,C9500DB,D4A00D0," _
        & "D8A167F,B5500D7,56A00CD,A5B147D,25D00D5,92D00CA,D2B027A,A9500D2,B550781,6CA00D9," _
        & "B5500CE,535157F,4DA00D6,A5B00CB,457037C,52B00D4,A9A0883,E9500DA,6AA00D0,AEA0680," _
        & "AB500D7,4B600CD,AAE047D,A5700D5,52600CA,F260379,D9500D1,5B50782,56A00D9,96D00CE," _
        & "4DD057F,4AD00D7,A4D00CB,D4D047B,D2500D3,D550883,B5400DA,B6A00CF,95A1680,95B00D8," _
        & "49B00CD,A97047D,A4B00D5,B270ACA,6A500DC,6D400D1,AF40681,AB600D9,93700CE,4AF057F," _
        & "49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00D8,C9600CD," _
        & "D95047C,D4A00D4,DA500C9,755027A,56A00D1,ABB0781,25D00DA,92D00CF,CAB057E,A9500D6," _
        & "B4A00CB,BAA047B,B5500D2,55D0983,4BA00DB,A5B00D0,5171680,52B00D8,A9300CD,795047D," _
        & "6AA00D4,AD500C9,5B5027A,4B600D2,96E0681,A4E00D9,D2600CE,EA6057E,D5300D5,5AA00CB," _
        & "76A037B,96D00D3,4AB0B83,4AD00DB,A4D00D0,D0B1680,D2500D7,D5200CC,DD4057C,B5A00D4," _
        & "56D00C9,55B027A,49B00D2,A570782,A4B00D9,AA500CE,B25157E,6D200D6,ADA00CA,4B6137B," _
        & "93700D3,49F08C9,49700DB,64B00D0,68A1680,EA500D7,6AA00CC,A6C147C,AAE00D4,92E00CA," _
        & "D2E0379,C9600D1,D550781,D4A00D9,DA400CD,5D5057E,56A00D6,A6C00CB,55D047B,52D00D3," _
        & "A9B0883,A9500DB,B4A00CF,B6A067F,AD500D7,55A00CD,ABA047C,A5A00D4,52B00CA,B27037A," _
        & "69300D1,7330781,6AA00D9,AD500CE,4B5157E,4B600D6,A5700CB,54E047C,D1600D2,E960882," _
        & "D5200DA,DAA00CF,6AA167F,56D00D7,4AE00CD,A9D047D,A2D00D4,D1500C9,F250279,D5200D1"

Private Const ylMd0 = "初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五" _
        & "十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十 "

Private Const ylMn0 = "正二三四五六七八九十冬腊"
Private Const ylTianGan0 = "甲乙丙丁戊已庚辛壬癸"
Private Const ylDiZhi0 = "子丑寅卯辰巳午未申酉戌亥"
Private Const ylShu0 = "鼠牛虎兔龙蛇马羊猴鸡狗猪"

'公历日期转农历
Function GetYLDate(ByVal strDate As String) As String

On Error GoTo aErr

    If Not IsDate(strDate) Then Exit Function
   
    Dim setDate As Date, tYear As Integer, tMonth As Integer, tDay As Integer
    setDate = CDate(strDate)
    tYear = Year(setDate): tMonth = Month(setDate): tDay = Day(setDate)
   
    '如果不是有效有日期，退出
    If tYear > 2100 Or tYear < 1900 Then Exit Function
   
    Dim daList() As String * 18, conDate As Date, thisMonths As String
    Dim AddYear As Integer, AddMonth As Integer, AddDay As Integer, getDay As Integer
    Dim YLyear As String, YLShuXing As String
    Dim dd0 As String, mm0 As String, ganzhi(0 To 59) As String * 2
    Dim RunYue As Boolean, RunYue1 As Integer, mDays As Integer, i As Integer
   
    '加载2年内的农历数据
    ReDim daList(tYear - 1 To tYear)
    daList(tYear - 1) = H2B(Mid(ylData, (tYear - 1900) * 8 + 1, 7))
    daList(tYear) = H2B(Mid(ylData, (tYear - 1900 + 1) * 8 + 1, 7))
   
    AddYear = tYear

initYL:

    AddMonth = CInt(Mid(daList(AddYear), 15, 2))
    AddDay = CInt(Mid(daList(AddYear), 17, 2))
    conDate = DateSerial(AddYear, AddMonth, AddDay)     '农历新年日期
   
    getDay = DateDiff("d", conDate, setDate) + 1        '相差天数
    If getDay < 1 Then AddYear = AddYear - 1: GoTo initYL
   
    thisMonths = Left(daList(AddYear), 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 i

    YLyear = ganzhi((AddYear - 4) Mod 60)
    YLShuXing = Mid(ylShu0, ((AddYear - 4) Mod 12) + 1, 1)
    If RunYue Then mm0 = "闰" & mm0
   
    GetYLDate = "农历" & YLyear & "(" & YLShuXing & ")年" & mm0 & dd0

aErr:
   
End Function


'农历转公历日期
'secondMonth 为真，则天示当 tMonth 是闰月时，取第二个月
Function GetDate(ByVal tYear As Integer, tMonth As Integer, tDay As Integer, Optional secondMonth As Boolean = False) As String

On Error GoTo aErr

    If tYear > 2100 Or tYear < 1899 Or tMonth > 12 Or tMonth < 1 Or tDay > 30 Or tDay < 1 Then Exit Function
   
    Dim thisMonths As String, ylNewYear As Date, toMonth As Integer
    Dim mDays As Integer, RunYue1 As Integer, i As Integer
    thisMonths = H2B(Mid(ylData, (tYear - 1899) * 8 + 1, 7))
   
    If tDay > 29 + CInt(Mid(thisMonths, tMonth, 1)) Then Exit Function
   
    ylNewYear = DateSerial(tYear, CInt(Mid(thisMonths, 15, 2)), CInt(Mid(thisMonths, 17, 2)))     '农历新年日期
   
    thisMonths = Left(thisMonths, 14)
    RunYue1 = Val("&H" & Right(thisMonths, 1))           '闰月月份
   
    toMonth = tMonth - 1
    If RunYue1 > 0 Then                                  '有闰月
        thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)
        If tMonth > RunYue1 Or (secondMonth And tMonth = RunYue1) Then toMonth = tMonth
    End If
    thisMonths = Left(thisMonths, 13)
        
    mDays = 0
    For i = 1 To toMonth
        mDays = mDays + 29 + CInt(Mid(thisMonths, i, 1))
    Next
    mDays = mDays + tDay
   
    GetDate = ylNewYear + mDays - 1

aErr:
   
End Function

'将压缩的阴历字符还原
Private Function H2B(ByVal strHex As String) As String
    Dim i As Integer, i1 As Integer, tmpV As String
    Const hStr = "0123456789ABCDEF"
    Const bStr = "0000000100100011010001010110011110001001101010111100110111101111"
   
    tmpV = UCase(Left(strHex, 3))
   
    '十六进制转二进制
    For i = 1 To Len(tmpV)
        i1 = InStr(hStr, Mid(tmpV, i, 1))
        H2B = H2B & Mid(bStr, (i1 - 1) * 4 + 1, 4)
    Next
   
    H2B = H2B & Mid(strHex, 4, 2)
   
    '十六进制转十进制
    H2B = H2B & "0" & CStr(Val("&H" & Right(strHex, 2)))
End Function

--------------------------；例：

=GetYLDate("1983-03-22")----》农历癸亥(猪)年二月初八

香川群子

除了大年初一、端午、中秋等几个大节日，农历已经完全用不上啦。

再去搞什么农历-公历转换，有什么意思嘛。

Fangfangyy

呵呵，的确是在弄历法相关的东西，特别感谢2楼专家！我先试试！

Fangfangyy

再次感谢wudixin96专家的帮助，呵呵，非常好用，而且数据范围比我在网上搜到的其它转换的范围要大得多！

wudixin96

原帖由 Fangfangyy 于 2010-6-27 10:46 发表
再次感谢wudixin96专家的帮助，呵呵，非常好用，而且数据范围比我在网上搜到的其它转换的范围要大得多！

只是转来而已，没什么的

香川群子

那么我问你，

农历的每年新历的排布，是完全有规律呢，还是没有规律，、
如果有规律的话，是怎样的规律呢？


而对于公历来说，则是非常地简单：
1. 一年12个月

2. 每月天数按31,28(29),31,30,31,30,31,31,30,31,30,31
其中2月天数平年28天，闰年29天

3. 2月闰年的规律基本上是按4年1润，即年份数能被4整除的非世纪年，(如2008年和2012年能被4整除是闰年)
  以及能被4整除的世纪年。(世纪年即能被100整除的年份，如1900年和2000年，其中2000年可被4整除是闰年)

=================================================

而农历的闰月，就相当复杂，还需要参考公历和节气的分布，

据说还有台湾历法院公布的历法日期和大陆的历法有差异的事。

基本上没有很好的规律，似乎只能硬推死算。


如果是这样的话，还是建议直接把农历废除了。


至于说农历对作物生长很有参考作用……

那么，国外除了亚洲地域，很多地方根本不用农历的，照样活下去……
可见，没有农历大概也是可以的。


因此，现在的农历，大概只有文化历史的存在意义啦。

zhao__feng

农历确实很搞,没规律,过几十年要调整

unsamesky

谁说农历没有用？

春    雨    惊    春    清    谷  天， 夏    满    忙    夏     暑相连；
立春，雨水，惊蛰，春分，清明，谷雨；   立夏，小满，忙种，夏至，小暑，大暑；

秋    处    露    秋    寒   霜降，    冬    雪    雪     东    小大寒。
立秋，处暑，白露，秋分，寒露，霜降；   立冬，小雪，大雪，东至，小寒，大寒。

上半年来六廿一，下半年是八廿三。
上半年，一般在每个月阳历的6号和21号左右，下半年，一般在每个月的8号和23号左右，均有一个节气。

每月两节不变更，最多相差一两天。
每个月基本两个节气（也有例外，较少），与上面的6，21,8,23相比相差一两天。


其实中国的农历表达了太阳，地球，月亮三者在中国土地上的运行位置和关系。
太阳直射北回归线的时间一般在6月22号左右，而这个时候恰好是中国农历夏至(字面意思就是夏天要来了)的日子。
而太阳在直射北回归线后，直射点将向赤道移动，当太阳直射赤道的时候，一般在9月23号左右，而这个时候一般是秋分。
而太阳直射南回归线，一般在12月22号左右，而这个时候，是冬至；
然后又直射到赤道，这个时候差不多是春分。

中国的古代历法，差不多是从秦汉时代统一并流传下来的。
要知道中国在封建社会曾经繁荣一时，但在科技上却是一步一步落后于欧洲国家。当中国更注重于诗词歌赋和八股的时候，外国人在打造现代科学的基石。而关于太阳运动，中国古代我想几乎是不可能有人进行过深入研究和观测的。

如果你是有心人，你可以留心一下，如果按照公历来统计，一年最冷是什么时候？12月？1月？2月？呵呵，其实当农历转到小寒的时候，天气就急转直下了。而什么时候最热？5月？6月？7月？8月？呵呵，有的时候好像热得早，有的时候好像9月都热得要命。其实看看农历如果闰了7月和8月，那就做好长期抗暑的准备吧。
千万别以为这是迷信。
其实当月亮经过地球表面的海洋上空时，这个地方会发生潮汐现象。而古人观测月亮变化所用到的朔月，望月，满月，玄月等等与农历的变化息息相关，而且也很浪漫！！
中国的农历虽然没有规律可循，但绝不是迷信，而是几百年来对四季变化规律的观察和总结。在那样的一个科技时代，已经实属不易了。而最新的农历历法，是以南京紫金山天文台观测总结出来的数据，对月亮运动和太阳运动的轨迹进行修正后计算出来的。也更加的科学了。


而看看其他的国家，也有他们的古农历。
法国：葡月、雾月、霜月、雪月、雨月、风月、芽月、花月、牧月、获月、热月、果月。
相当著名的拿破仑经过“雾月”政变开辟了不可一世的法兰西王朝。

而与中国文化一直源远流长的日本也是在民治维新以后才采用的公历。而韩国目前一直都沿用着农历。
当然，中国的农历对于其他国家来说并不一定适用。因为中国农历的总结全部是按照中国这块土地受到太阳和月亮运动而总结出来的。6月对于南半球国家来说，可能要进入冬季了！！

农历，对于研究历史，还有天文都有所帮助的。何况，我还指着它好回家过年放大假呢！嘿嘿

yykxiaoyang

看你的名子,你不会是日本人吧,如果是,就说我手贱。

你对农历知道多少，还废了农历，在中国农村，有几个地方的农民是用公历的，反正我只要一回老家，要知道今天几号还得看手机，要知道有多少人过生日是过农历。。。。。。
不说了，怀疑你不是中国人，还废农历，有种你把汉字也废了得了。。。。。。。。。