VB的农历算法(1900-2090)

从网上找到的VB农历代码收藏备用

1. Option Explicit  
2.  
3. Public LunarInfo(1 To 191) As Double '从1900-2090年这150年的农历信息码  
4.  
5. 'Public SolarMonth(1 To 12) As Integer '阳历12个月的天数  
6.  
7. Public Gan(1 To 10) As String       '农历的天干  
8. Public Zhi(1 To 12) As String       '农历的地支  
9. Public Animals(1 To 12) As String   '农历的属象  
10. Public SolarTerm(1 To 24) As String '阳历的节气  
11.  
12. Public sTermInfo(1 To 24) As Double '阳历节气的信息码  
13. Public nStr1(1 To 11) As String '从一到十日  
14. Public nStr2(1 To 5) As String '初十廿卅　'  
15.  
16. 'Public MonthName(1 To 12) As String '每个月的英文名称  
17.  
18. Public sFtv(1 To 17) As String '阳历的节日  
19. Public lFtv(1 To 10) As String '农历的节日  
20. 'Public wFtv(1 To 30) As String '西方的节日  
21.  
22. Public Sub SetValue()  
23. Dim i As Integer 
24.  
25. '阳历节日：前四位数字为阳历的MMDD（月日），后面的文字为意义  
26. sFtv(1) = "0101元旦" 
27. sFtv(2) = "0214情人节" 
28. sFtv(3) = "0308妇女节" 
29. sFtv(4) = "0312植树节" 
30. sFtv(5) = "0315权益日" 
31. sFtv(6) = "0401愚人节" 
32. sFtv(7) = "0501劳动节" 
33. sFtv(8) = "0504青年节" 
34. sFtv(9) = "0512护士节" 
35. sFtv(10) = "0601儿童节" 
36. sFtv(11) = "0701建党节" 
37. sFtv(12) = "0801建军节" 
38. sFtv(13) = "0808父亲节" 
39. sFtv(14) = "0910教师节" 
40. sFtv(15) = "1001国庆节" 
41. sFtv(16) = "1006老人节" 
42. sFtv(17) = "1225圣诞节" 
43.  
44. '农历的节日：日期表示的是农历的某月某日  
45.  
46. lFtv(1) = "0101春节" 
47. lFtv(2) = "0115元宵节" 
48. lFtv(3) = "0505端午节" 
49. lFtv(4) = "0707七夕节" 
50. lFtv(5) = "0715中元节" 
51. lFtv(6) = "0815中秋节" 
52. lFtv(7) = "0909重阳节" 
53. lFtv(8) = "1208腊八节" 
54. lFtv(9) = "1224小年" 
55. lFtv(10) = "0100除夕" 
56.  
57. 'wFtv(1) = ""  
58. 'wFtv(2) = "0231总统日"  
59. 'wFtv(3) = "0520母亲节"  
60. 'wFtv(4) = ""  
61. 'wFtv(5) = "0531胜利日"  
62. 'wFtv(6) = "0716合作节"  
63. 'wFtv(7) = "0730被奴周"  
64. 'wFtv(8) = ""  
65. 'wFtv(9) = ""  
66. 'wFtv(10) = "1021哥伦布日"  
67. 'wFtv(11) = "1144感恩节"  
68.  
69. '********************  
70.  
71. LunarInfo(1) = &H4BD8  
72. LunarInfo(2) = &H4AE0  
73. LunarInfo(3) = &HA570  
74. LunarInfo(4) = &H54D5  
75. LunarInfo(5) = &HD260  
76. LunarInfo(6) = &HD950  
77. LunarInfo(7) = &H16554  
78. LunarInfo(8) = &H56A0  
79. LunarInfo(9) = &H9AD0  
80. LunarInfo(10) = &H55D2  
81. LunarInfo(11) = &H4AE0  
82. LunarInfo(12) = &HA5B6  
83. LunarInfo(13) = &HA4D0  
84. LunarInfo(14) = &HD250  
85. LunarInfo(15) = &H1D255  
86. LunarInfo(16) = &HB540  
87. LunarInfo(17) = &HD6A0  
88. LunarInfo(18) = &HADA2  
89. LunarInfo(19) = &H95B0  
90. LunarInfo(20) = &H14977  
91. LunarInfo(21) = &H4970  
92. LunarInfo(22) = &HA4B0  
93. LunarInfo(23) = &HB4B5  
94. LunarInfo(24) = &H6A50  
95. LunarInfo(25) = &H6D40  
96. LunarInfo(26) = &H1AB54  
97. LunarInfo(27) = &H2B60  
98. LunarInfo(28) = &H9570  
99. LunarInfo(29) = &H52F2  
100. LunarInfo(30) = &H4970  
101. LunarInfo(31) = &H6566  
102. LunarInfo(32) = &HD4A0  
103. LunarInfo(33) = &HEA50  
104. LunarInfo(34) = &H6E95  
105. LunarInfo(35) = &H5AD0  
106. LunarInfo(36) = &H2B60  
107. LunarInfo(37) = &H186E3  
108. LunarInfo(38) = &H92E0  
109. LunarInfo(39) = &H1C8D7  
110. LunarInfo(40) = &HC950  
111. LunarInfo(41) = &HD4A0  
112. LunarInfo(42) = &H1D8A6  
113. LunarInfo(43) = &HB550  
114. LunarInfo(44) = &H56A0  
115. LunarInfo(45) = &H1A5B4  
116. LunarInfo(46) = &H25D0  
117. LunarInfo(47) = &H92D0  
118. LunarInfo(48) = &HD2B2  
119. LunarInfo(49) = &HA950  
120. LunarInfo(50) = &HB557  
121. LunarInfo(51) = &H6CA0  
122. LunarInfo(52) = &HB550  
123. LunarInfo(53) = &H15355  
124. LunarInfo(54) = &H4DA0  
125. LunarInfo(55) = &HA5D0  
126. LunarInfo(56) = &H14573  
127. LunarInfo(57) = &H52D0  
128. LunarInfo(58) = &HA9A8  
129. LunarInfo(59) = &HE950  
130. LunarInfo(60) = &H6AA0  
131. LunarInfo(61) = &HAEA6  
132. LunarInfo(62) = &HAB50  
133. LunarInfo(63) = &H4B60  
134. LunarInfo(64) = &HAAE4  
135. LunarInfo(65) = &HA570  
136. LunarInfo(66) = &H5260  
137. LunarInfo(67) = &HF263  
138. LunarInfo(68) = &HD950  
139. LunarInfo(69) = &H5B57  
140. LunarInfo(70) = &H56A0  
141. LunarInfo(71) = &H96D0  
142. LunarInfo(72) = &H4DD5  
143. LunarInfo(73) = &H4AD0  
144. LunarInfo(74) = &HA4D0  
145. LunarInfo(75) = &HD4D4  
146. LunarInfo(76) = &HD250  
147. LunarInfo(77) = &HD558  
148. LunarInfo(78) = &HB540  
149. LunarInfo(79) = &HB5A0  
150. LunarInfo(80) = &H195A6  
151. LunarInfo(81) = &H95B0  
152. LunarInfo(82) = &H49B0  
153. LunarInfo(83) = &HA974  
154. LunarInfo(84) = &HA4B0  
155. LunarInfo(85) = &HB27A  
156. LunarInfo(86) = &H6A50  
157. LunarInfo(87) = &H6D40  
158. LunarInfo(88) = &HAF46  
159. LunarInfo(89) = &HAB60  
160. LunarInfo(90) = &H9570  
161. LunarInfo(91) = &H4AF5  
162. LunarInfo(92) = &H4970  
163. LunarInfo(93) = &H64B0  
164. LunarInfo(94) = &H74A3  
165. LunarInfo(95) = &HEA50  
166. LunarInfo(96) = &H6B58  
167. LunarInfo(97) = &H55C0  
168. LunarInfo(98) = &HAB60  
169. LunarInfo(99) = &H96D5  
170. LunarInfo(100) = &H92E0  
171. LunarInfo(101) = &HC960  
172. LunarInfo(102) = &HD954  
173. LunarInfo(103) = &HD4A0  
174. LunarInfo(104) = &HDA50  
175. LunarInfo(105) = &H7552  
176. LunarInfo(106) = &H56A0  
177. LunarInfo(107) = &HABB7  
178. LunarInfo(108) = &H25D0  
179. LunarInfo(109) = &H92D0  
180. LunarInfo(110) = &HCAB5  
181. LunarInfo(111) = &HA950  
182. LunarInfo(112) = &HB4A0  
183. LunarInfo(113) = &HBAA4  
184. LunarInfo(114) = &HAD50  
185. LunarInfo(115) = &H55D9  
186. LunarInfo(116) = &H4BA0  
187. LunarInfo(117) = &HA5B0  
188. LunarInfo(118) = &H15176  
189. LunarInfo(119) = &H52B0  
190. LunarInfo(120) = &HA930  
191. LunarInfo(121) = &H7954  
192. LunarInfo(122) = &H6AA0  
193. LunarInfo(123) = &HAD50  
194. LunarInfo(124) = &H5B52  
195. LunarInfo(125) = &H4B60  
196. LunarInfo(126) = &HA6E6  
197. LunarInfo(127) = &HA4E0  
198. LunarInfo(128) = &HD260  
199. LunarInfo(129) = &HEA65  
200. LunarInfo(130) = &HD530  
201. LunarInfo(131) = &H5AA0  
202. LunarInfo(132) = &H76A3  
203. LunarInfo(133) = &H96D0  
204. LunarInfo(134) = &H4BD7  
205. LunarInfo(135) = &H4AD0  
206. LunarInfo(136) = &HA4D0  
207. LunarInfo(137) = &H1D0B6  
208. LunarInfo(138) = &HD250  
209. LunarInfo(139) = &HD520  
210. LunarInfo(140) = &HDD45  
211. LunarInfo(141) = &HB5A0  
212. LunarInfo(142) = &H56D0  
213. LunarInfo(143) = &H55B2  
214. LunarInfo(144) = &H49B0  
215. LunarInfo(145) = &HA577  
216. LunarInfo(146) = &HA4B0  
217. LunarInfo(147) = &HAA50  
218. LunarInfo(148) = &H1B255  
219. LunarInfo(149) = &H6D20  
220. LunarInfo(150) = &HADA0  
221.       
222. LunarInfo(151) = &H14B63  
223. LunarInfo(152) = &H9370  
224. LunarInfo(153) = &H49F8  
225. LunarInfo(154) = &H4970  
226. LunarInfo(155) = &H64B0  
227. LunarInfo(156) = &H168A6  
228. LunarInfo(157) = &HEA50  
229. LunarInfo(158) = &H6B20  
230. LunarInfo(159) = &H1A6C4  
231. LunarInfo(160) = &HAAE0  
232. LunarInfo(161) = &H92E0  
233. LunarInfo(162) = &HD2E3  
234. LunarInfo(163) = &HC960  
235. LunarInfo(164) = &HD557  
236. LunarInfo(165) = &HD4A0  
237. LunarInfo(166) = &HDA50  
238. LunarInfo(167) = &H5D55  
239. LunarInfo(168) = &H56A0  
240. LunarInfo(169) = &HA6D0  
241. LunarInfo(170) = &H55D4  
242. LunarInfo(171) = &H52D0  
243.  
244. LunarInfo(172) = &HA9B8  
245. LunarInfo(173) = &HA950  
246. LunarInfo(174) = &HB4A0  
247. LunarInfo(175) = &HB6A6  
248. LunarInfo(176) = &HAD50  
249. LunarInfo(177) = &H55A0  
250. LunarInfo(178) = &HABA4  
251. LunarInfo(179) = &HA5B0  
252. LunarInfo(180) = &H52B0  
253. LunarInfo(181) = &HB273  
254.  
255. LunarInfo(182) = &H6930  
256. LunarInfo(183) = &H7337  
257. LunarInfo(184) = &H6A60  
258. LunarInfo(185) = &HAD50  
259. LunarInfo(186) = &H6B55  
260. LunarInfo(187) = &H4B60  
261. LunarInfo(188) = &HA570  
262. LunarInfo(189) = &H54E4  
263. LunarInfo(190) = &HD160  
264. LunarInfo(191) = &HE968  
265.  
266.  
267. Dim s1, s2, s3, s4, s5, s6, s7 As String 
268. s1 = "甲乙丙丁戊己庚辛壬癸" 
269. s2 = "子丑寅卯辰巳午未申酉戌亥" 
270. s3 = "鼠牛虎兔龙蛇马羊猴鸡狗猪" 
271. s4 = "小寒大寒立春雨水惊蛰春分清明谷雨立夏小满芒种夏至小暑大暑立秋处暑白露秋分寒露霜降立冬小雪大雪冬至" 
272. s5 = "000000,021208,042467,063836,085337,107014,128867,150921,173149,195551,218072,240693,263343,285989,308563,331033,353350,375494,397447,419210,440795,462224,483532,504758" 
273. s6 = "一二三四五六七八九十日" 
274. s7 = "初十廿卅　" 
275.  
276. For i = 1 To 24  
277.     If i <= 10 Then Gan(i) = Mid(s1, i, 1)  
278.     If i <= 12 Then 
279.       Zhi(i) = Mid(s2, i, 1)  
280.       Animals(i) = Mid(s3, i, 1)  
281.     End If 
282.     SolarTerm(i) = Mid(s4, (i - 1) * 2 + 1, 2)  
283.     sTermInfo(i) = Val(Mid(s5, (i - 1) * 7 + 1, 6))  
284.     If i <= 11 Then nStr1(i) = Mid(s6, i, 1)  
285.     If i <= 5 Then nStr2(i) = Mid(s7, i, 1)  
286. Next i  
287.  
288. End Sub 
289.  
290.  
291. '**************************************  
292.  
293. '日历系统中的常用处理函数  
294.  
295. '**************************************  
296.  
297. '传回农历 y年m月的总天数  
298.  
299. Function lMonthDays(ByVal Y As Integer, ByVal m As Integer) As Integer 
300. If Y < 1900 Then Y = 1900  
301. If (LunarInfo(Y - 1900 + 1) And Int(&H10000 / (2 ^ m))) = 0 Then 
302.     lMonthDays = 29  
303. Else 
304.     lMonthDays = 30  
305. End If 
306. End Function 
307.  
308.  
309. '传回农历 y年闰哪个月 1-12 , 没闰传回 0  
310.  
311. Function LeapMonth(ByVal Y As Integer) As Integer 
312. LeapMonth = 0  
313. If Y >= 1900 Then LeapMonth = (LunarInfo(Y - 1900 + 1) And &HF)  
314. End Function 
315.  
316.  
317. '传回农历 y年闰月的天数  
318.  
319. Function LeapDays(ByVal Y As Integer) As Integer 
320. Dim m As Integer 
321. Dim l As Double 
322. m = LeapMonth(Y)  
323. If m = 0 Then 
324.     LeapDays = 0  
325. Else 
326.     l = LunarInfo(Y - 1900 + 1)  
327.     If l < 0 Then l = l * (-1)  
328.     l = (l And &H10000)  
329.     If l = 0 Then 
330.       LeapDays = 29  
331.     Else 
332.       LeapDays = 30  
333.     End If 
334. End If 
335. End Function 
336.  
337.  
338. '传回农历 y年的总天数  
339.  
340. Function lYearDays(ByVal Y As Integer) As Integer 
341. Dim i, Sum As Double 
342. Sum = 0  
343. For i = 1 To 12  
344.     Sum = Sum + lMonthDays(Y, i)  
345. Next i  
346. lYearDays = Sum + LeapDays(Y)  
347. End Function 
348.  
349.  
350. '传回阳历 y年某m月的天数  
351.  
352. 'Function SolarDays(ByVal Y As Integer, ByVal m As Integer) As Integer  
353. ' If m = 2 Then  
354. '    If (Y Mod 4 = 0 And Y Mod 100 <> 0) Or (Y Mod 400 = 0) Then  
355. '      SolarDays = 29  
356. '    Else  
357. '      SolarDays = 28  
358. '    End If  
359. ' Else  
360. '    SolarDays = SolarMonth(m)  
361. ' End If  
362. 'End Function  
363.  
364.  
365. '根据给定的阳历，返回农历的日期  
366.  
367. Function GetLunar(ByVal SolarDate As Date) As String 
368. Dim DaysOffset As Long 
369. Dim i As Integer 
370. Dim Temp As Long 
371. Dim lyear, lmonth, lday As Integer 
372.  
373. '/  
374. If SolarDate <= CDate("2000-2-5") Then 
375.     DaysOffset = SolarDate - CDate("1900-1-31")  
376.     i = 1900  
377.     Do While i < 2001 And DaysOffset >= 0  
378.       Temp = lYearDays(i)  
379.       DaysOffset = DaysOffset - Temp  
380.       i = i + 1  
381.     Loop 
382.     If DaysOffset < 0 Then 
383.       DaysOffset = DaysOffset + Temp  
384.       i = i - 1  
385.     End If 
386.     lyear = i  
387. Else 
388.     DaysOffset = SolarDate - CDate("2000-2-5")  
389.     i = 2000  
390.     Do While i < 2091 And DaysOffset >= 0  
391.       Temp = lYearDays(i)  
392.       DaysOffset = DaysOffset - Temp  
393.       i = i + 1  
394.     Loop 
395.     If DaysOffset < 0 Then 
396.       DaysOffset = DaysOffset + Temp  
397.       i = i - 1  
398.     End If 
399.     lyear = i  
400. End If 
401.  
402. '  
403.  
404. Dim Leap As Integer 
405. Dim IsLeap As Boolean 
406. Leap = LeapMonth(i)  
407. IsLeap = False 
408. i = 1  
409. Do While i < 13 And DaysOffset > 0  
410.     If Leap > 0 And i = (Leap + 1) And IsLeap = False Then 
411.       i = i - 1  
412.       IsLeap = True 
413.       Temp = LeapDays(lyear)  
414.     Else 
415.       Temp = lMonthDays(lyear, i)  
416.     End If 
417.     If IsLeap And i = (Leap + 1) Then IsLeap = False 
418.     DaysOffset = DaysOffset - Temp  
419.     i = i + 1  
420. Loop 
421.  
422. If DaysOffset = 0 And Leap > 0 And i = Leap + 1 Then 
423.     If IsLeap Then 
424.       IsLeap = False 
425.     Else 
426.       IsLeap = True 
427.       i = i - 1  
428.     End If 
429. End If 
430. If DaysOffset < 0 Then 
431.     DaysOffset = DaysOffset + Temp  
432.     i = i - 1  
433. End If 
434. lmonth = i  
435. lday = DaysOffset + 1  
436. '返回特殊标志的字符串  
437. If IsLeap Then 
438.     GetLunar = "1" & Format(lyear, "0000") & Format(lmonth, "00") & Format(lday, "00")  
439. Else 
440.     GetLunar = "0" & Format(lyear, "0000") & Format(lmonth, "00") & Format(lday, "00")  
441. End If 
442.  
443. End Function 
444.  
445.  
446. '将年份用天干地支表示  
447. Public Function GanZhi(ByVal syear As Integer) As String 
448. Dim strGan, strZhi As String 
449.  
450. strGan = Gan((syear - 1900 + 6) Mod 10 + 1)  
451. strZhi = Zhi((syear - 1900 + 12) Mod 12 + 1)  
452. GanZhi = strGan + strZhi + "年" 
453.  
454. End Function 
455.  
456.  
457. '将月份用农历表示  
458. Public Function CnMonth(ByVal smonth As Integer) As String 
459.  
460. If smonth < 10 Then 
461.     CnMonth = nStr1(smonth) + "月" 
462. ElseIf smonth = 10 Then 
463.     CnMonth = "十" + "月" 
464. Else 
465.     CnMonth = "十" + nStr1(smonth Mod 10) + "月" 
466. End If 
467. End Function 
468.  
469.  
470. '将日用农历表示  
471. Public Function CnDay(ByVal sday As Integer) As String 
472. If sday <= 10 Then 
473.     CnDay = "初" + nStr1(sday)  
474. ElseIf sday < 20 Then 
475.     CnDay = "十" + nStr1(sday Mod 10)  
476. ElseIf sday = 20 Then 
477.     CnDay = "廿十" 
478. ElseIf sday < 30 Then 
479.     CnDay = "廿" + nStr1(sday Mod 10)  
480. Else 
481.     CnDay = "卅十" 
482. End If 
483. End Function 
484.  
485. '根据年份返回属象  
486. Public Function Animal(ByVal syear As Integer) As String 
487. Animal = Animals((syear - 1900) Mod 12 + 1)  
488. End Function 
489.  
490.  
491. '某y年的第n个节气的日期(从1小寒起算)  
492. Function sTerm(ByVal Y, n As Integer) As Date 
493. Dim D1, D2 As Double 
494. D1 = (31556925.9747 * (Y - 1900) + sTermInfo(n) * 60#)  
495. D2 = DateDiff("s", "1970-1-1 0:0", "1900-1-6 2:5") + D1  
496. D1 = D2 / 2  
497. sTerm = DateAdd("s", D2 - D1, DateAdd("s", D1, "1970-1-1 0:0"))  
498. sTerm = Format(sTerm, "yyyy/mm/dd")  
499. End Function 
500.  
501.  
502. '根据阳历返回其节气，若不是则返回空  
503. Public Function GetTerm(ByVal sDate As Date) As String 
504. Dim Y, m As Integer 
505. Y = Year(sDate)  
506. m = Month(sDate)  
507. GetTerm = " " 
508. If sTerm(Y, m * 2 - 1) = sDate Then 
509.     GetTerm = SolarTerm(m * 2 - 1)  
510. ElseIf sTerm(Y, m * 2) = sDate Then 
511.     GetTerm = SolarTerm(m * 2)  
512. End If 
513. End Function 
514. '返回阳历是该月的第几个星期几的字符串，如:0520表示5月份第2个星期日  
515.  
516. Function GetMonthWeek(ByVal sDate As Date) As String 
517. Dim D0 As Date 
518. D0 = CDate(Year(sDate) & "-" & Month(sDate) & "-1")  
519. GetMonthWeek = Format(Month(sDate), "00") & (Int((Day(sDate) - 1 + Weekday(D0) - 1) / 7) + 1) & Weekday(sDate) - 1  
520. End Function 

 

转载于:https://blog.51cto.com/vbcodeworkers/726624