VB的农历算法(1900-2090)

前端之家收集整理的这篇文章主要介绍了VB的农历算法(1900-2090)前端之家小编觉得挺不错的,现在分享给大家,也给大家做个参考。

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

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

猜你在找的VB相关文章