农历与公历互相转换的自定义函数（强大）

时光鸟

1. 
   
2. '公历转农历模块
   
3. '原创：互联网
   
4. '修正：阿勇 2005/1/12
   
5. '// 农历数据定义 //
   
6. '先以 H2B 函数还原成长度为 18 的字符串，其定义如下：
   
7. '前12个字节代表1-12月：1为大月，0为小月；压缩成十六进制(1-3位)
   
8. '第13位为闰月的情况，1为大月30天，0为小月29天；(4位)
   
9. '第14位为闰月的月份，如果不是闰月为0，否则给出月份(5位)
   
10. '最后4位为当年农历新年的公历日期，如0131代表1月31日；当作数值转十六进制(6-7位)
    
11. 
    
12. '农历常量(1899~2100，共202年）
    
13. Private Const ylData = "AB500D2,4BD0883," _
    
14.         & "4AE00DB,A5700D0,54D0581,D2600D8,D9500CC,655147D,56A00D5,9AD00CA,55D027A,4AE00D2," _
    
15.         & "A5B0682,A4D00DA,D2500CE,D25157E,B5500D6,56A00CC,ADA027B,95B00D3,49717C9,49B00DC," _
    
16.         & "A4B00D0,B4B0580,6A500D8,6D400CD,AB5147C,2B600D5,95700CA,52F027B,49700D2,6560682," _
    
17.         & "D4A00D9,EA500CE,6A9157E,5AD00D6,2B600CC,86E137C,92E00D3,C8D1783,C9500DB,D4A00D0," _
    
18.         & "D8A167F,B5500D7,56A00CD,A5B147D,25D00D5,92D00CA,D2B027A,A9500D2,B550781,6CA00D9," _
    
19.         & "B5500CE,535157F,4DA00D6,A5B00CB,457037C,52B00D4,A9A0883,E9500DA,6AA00D0,AEA0680," _
    
20.         & "AB500D7,4B600CD,AAE047D,A5700D5,52600CA,F260379,D9500D1,5B50782,56A00D9,96D00CE," _
    
21.         & "4DD057F,4AD00D7,A4D00CB,D4D047B,D2500D3,D550883,B5400DA,B6A00CF,95A1680,95B00D8," _
    
22.         & "49B00CD,A97047D,A4B00D5,B270ACA,6A500DC,6D400D1,AF40681,AB600D9,93700CE,4AF057F," _
    
23.         & "49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00D8,C9600CD," _
    
24.         & "D95047C,D4A00D4,DA500C9,755027A,56A00D1,ABB0781,25D00DA,92D00CF,CAB057E,A9500D6," _
    
25.         & "B4A00CB,BAA047B,B5500D2,55D0983,4BA00DB,A5B00D0,5171680,52B00D8,A9300CD,795047D," _
    
26.         & "6AA00D4,AD500C9,5B5027A,4B600D2,96E0681,A4E00D9,D2600CE,EA6057E,D5300D5,5AA00CB," _
    
27.         & "76A037B,96D00D3,4AB0B83,4AD00DB,A4D00D0,D0B1680,D2500D7,D5200CC,DD4057C,B5A00D4," _
    
28.         & "56D00C9,55B027A,49B00D2,A570782,A4B00D9,AA500CE,B25157E,6D200D6,ADA00CA,4B6137B," _
    
29.         & "93700D3,49F08C9,49700DB,64B00D0,68A1680,EA500D7,6AA00CC,A6C147C,AAE00D4,92E00CA," _
    
30.         & "D2E0379,C9600D1,D550781,D4A00D9,DA400CD,5D5057E,56A00D6,A6C00CB,55D047B,52D00D3," _
    
31.         & "A9B0883,A9500DB,B4A00CF,B6A067F,AD500D7,55A00CD,ABA047C,A5A00D4,52B00CA,B27037A," _
    
32.         & "69300D1,7330781,6AA00D9,AD500CE,4B5157E,4B600D6,A5700CB,54E047C,D1600D2,E960882," _
    
33.         & "D5200DA,DAA00CF,6AA167F,56D00D7,4AE00CD,A9D047D,A2D00D4,D1500C9,F250279,D5200D1"
    
34. 
    
35. Private Const ylMd0 = "初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五" _
    
36.         & "十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十 "
    
37. 
    
38. Private Const ylMn0 = "正二三四五六七八九十冬腊"
    
39. Private Const ylTianGan0 = "甲乙丙丁戊已庚辛壬癸"
    
40. Private Const ylDiZhi0 = "子丑寅卯辰巳午未申酉戌亥"
    
41. Private Const ylShu0 = "鼠牛虎兔龙蛇马羊猴鸡狗猪"
    
42. 
    
43. '公历日期转农历
    
44. Function GetYLDate(ByVal strDate As String) As String
    
45. 
    
46. On Error GoTo aErr
    
47. 
    
48.     If Not IsDate(strDate) Then Exit Function
    
49.    
    
50.     Dim setDate As Date, tYear As Integer, tMonth As Integer, tDay As Integer
    
51.     setDate = CDate(strDate)
    
52.     tYear = Year(setDate): tMonth = Month(setDate): tDay = Day(setDate)
    
53.    
    
54.     '如果不是有效有日期，退出
    
55.     If tYear > 2100 Or tYear < 1900 Then Exit Function
    
56.    
    
57.     Dim daList() As String * 18, conDate As Date, thisMonths As String
    
58.     Dim AddYear As Integer, AddMonth As Integer, AddDay As Integer, getDay As Integer
    
59.     Dim YLyear As String, YLShuXing As String
    
60.     Dim dd0 As String, mm0 As String, ganzhi(0 To 59) As String * 2
    
61.     Dim RunYue As Boolean, RunYue1 As Integer, mDays As Integer, i As Integer
    
62.    
    
63.     '加载2年内的农历数据
    
64.     ReDim daList(tYear - 1 To tYear)
    
65.     daList(tYear - 1) = H2B(Mid(ylData, (tYear - 1900) * 8 + 1, 7))
    
66.     daList(tYear) = H2B(Mid(ylData, (tYear - 1900 + 1) * 8 + 1, 7))
    
67.    
    
68.     AddYear = tYear
    
69. 
    
70. initYL:
    
71. 
    
72.     AddMonth = CInt(Mid(daList(AddYear), 15, 2))
    
73.     AddDay = CInt(Mid(daList(AddYear), 17, 2))
    
74.     conDate = DateSerial(AddYear, AddMonth, AddDay)     '农历新年日期
    
75.    
    
76.     getDay = DateDiff("d", conDate, setDate) + 1        '相差天数
    
77.     If getDay < 1 Then AddYear = AddYear - 1: GoTo initYL
    
78.    
    
79.     thisMonths = Left(daList(AddYear), 14)
    
80.     RunYue1 = Val("&H" & Right(thisMonths, 1))           '闰月月份
    
81.     If RunYue1 > 0 Then                                  '有闰月
    
82.         thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)
    
83.     End If
    
84.     thisMonths = Left(thisMonths, 13)
    
85.    
    
86.     For i = 1 To 13                                      '计算天数
    
87.         mDays = 29 + CInt(Mid(thisMonths, i, 1))
    
88.         If getDay > mDays Then
    
89.             getDay = getDay - mDays
    
90.         Else
    
91.             If RunYue1 > 0 Then
    
92.                 If i = RunYue1 + 1 Then RunYue = True
    
93.                 If i > RunYue1 Then i = i - 1
    
94.             End If
    
95.             
    
96.             AddMonth = i
    
97.             AddDay = getDay
    
98.             Exit For
    
99.         End If
    
100.     Next
     
101.    
     
102.     dd0 = Mid(ylMd0, (AddDay - 1) * 2 + 1, 2)
     
103.     mm0 = Mid(ylMn0, AddMonth, 1) + "月"
     
104.    
     
105.     For i = 0 To 59
     
106.         ganzhi(i) = Mid(ylTianGan0, (i Mod 10) + 1, 1) + Mid(ylDiZhi0, (i Mod 12) + 1, 1)
     
107.     Next i
     
108. 
     
109.     YLyear = ganzhi((AddYear - 4) Mod 60)
     
110.     YLShuXing = Mid(ylShu0, ((AddYear - 4) Mod 12) + 1, 1)
     
111.     If RunYue Then mm0 = "闰" & mm0
     
112.    
     
113.     GetYLDate = "农历" & YLyear & "(" & YLShuXing & ")年" & mm0 & dd0
     
114. 
     
115. aErr:
     
116.    
     
117. End Function
     
118. 
     
119. 
     
120. '农历转公历日期
     
121. 'secondMonth 为真，则天示当 tMonth 是闰月时，取第二个月
     
122. Function GetDate(ByVal tYear As Integer, tMonth As Integer, tDay As Integer, Optional secondMonth As Boolean = False) As String
     
123. 
     
124. On Error GoTo aErr
     
125. 
     
126.     If tYear > 2100 Or tYear < 1899 Or tMonth > 12 Or tMonth < 1 Or tDay > 30 Or tDay < 1 Then Exit Function
     
127.    
     
128.     Dim thisMonths As String, ylNewYear As Date, toMonth As Integer
     
129.     Dim mDays As Integer, RunYue1 As Integer, i As Integer
     
130.     thisMonths = H2B(Mid(ylData, (tYear - 1899) * 8 + 1, 7))
     
131.    
     
132.     If tDay > 29 + CInt(Mid(thisMonths, tMonth, 1)) Then Exit Function
     
133.    
     
134.     ylNewYear = DateSerial(tYear, CInt(Mid(thisMonths, 15, 2)), CInt(Mid(thisMonths, 17, 2)))     '农历新年日期
     
135.    
     
136.     thisMonths = Left(thisMonths, 14)
     
137.     RunYue1 = Val("&H" & Right(thisMonths, 1))           '闰月月份
     
138.    
     
139.     toMonth = tMonth - 1
     
140.     If RunYue1 > 0 Then                                  '有闰月
     
141.         thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)
     
142.         If tMonth > RunYue1 Or (secondMonth And tMonth = RunYue1) Then toMonth = tMonth
     
143.     End If
     
144.     thisMonths = Left(thisMonths, 13)
     
145.         
     
146.     mDays = 0
     
147.     For i = 1 To toMonth
     
148.         mDays = mDays + 29 + CInt(Mid(thisMonths, i, 1))
     
149.     Next
     
150.     mDays = mDays + tDay
     
151.    
     
152.     GetDate = ylNewYear + mDays - 1
     
153. 
     
154. aErr:
     
155.    
     
156. End Function
     
157. 
     
158. '将压缩的阴历字符还原
     
159. Private Function H2B(ByVal strHex As String) As String
     
160.     Dim i As Integer, i1 As Integer, tmpV As String
     
161.     Const hStr = "0123456789ABCDEF"
     
162.     Const bStr = "0000000100100011010001010110011110001001101010111100110111101111"
     
163.    
     
164.     tmpV = UCase(Left(strHex, 3))
     
165.    
     
166.     '十六进制转二进制
     
167.     For i = 1 To Len(tmpV)
     
168.         i1 = InStr(hStr, Mid(tmpV, i, 1))
     
169.         H2B = H2B & Mid(bStr, (i1 - 1) * 4 + 1, 4)
     
170.     Next
     
171.    
     
172.     H2B = H2B & Mid(strHex, 4, 2)
     
173.    
     
174.     '十六进制转十进制
     
175.     H2B = H2B & "0" & CStr(Val("&H" & Right(strHex, 2)))
     
176. End Function

复制代码

840205910

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

时光鸟

840205910 发表于 2013-1-24 16:09
'公历转农历模块
'原创：互联网
'修正：阿勇 2005/1/12

互联网是这个函数的作者？还是说摘自互联网？我搜了下，有个网页上的确有这个信息，我加上去。

zengxp

太强大了。{:soso_e179:}

lsss1111

太强了，不董，但能用了，谢谢！

ugyun

农历转公历sGetDate这个函数该怎么用呢？要转换的农历格式是什么样的？

maditate

农历(夏历,殷历,古历,黄历,旧历)
http://blog.csai.cn/user1/265/archives/2006/3236.html

ugyun

这个公历转农历好用，但农历转公历如何运用呢？公式如何表达？

ugyun

经测试，里面的自定义函数GetYLDate有问题，如农历日期1955年十月初一，对应的公历日期应为1955－11－14，但这个自定义函数显示为1955－11－13，再如农历日期2013年五月初一，对应的公历日期应为2013－6－8，自定义函数显示为2013－6－9，不知能不能修正，实际上上面那两个日期所在的农历月份公农历都对不上

lsjcx

农历转公历显示格式为2014年1月1日怎么改？现在是1204/1/1。