VB的农历算法(1900-2090)

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

 
 

  
  
OptionExplicit 
  
  

  
  
PublicLunarInfo(1To191)AsDouble'从1900-2090年这150年的农历信息码 
  
  

  
  
'PublicSolarMonth(1To12)AsInteger'阳历12个月的天数 
  
  

  
  
PublicGan(1To10)AsString'农历的天干 
  
  
PublicZhi(1To12)AsString'农历的地支 
  
  
PublicAnimals(1To12)AsString'农历的属象 
  
  
PublicSolarTerm(1To24)AsString'阳历的节气 
  
  

  
  
PublicsTermInfo(1To24)AsDouble'阳历节气的信息码 
  
  
PublicnStr1(1To11)AsString'从一到十日 
  
  
PublicnStr2(1To5)AsString'初十廿卅　' 
  
  

  
  
'PublicMonthName(1To12)AsString'每个月的英文名称 
  
  

  
  
PublicsFtv(1To17)AsString'阳历的节日 
  
  
PubliclFtv(1To10)AsString'农历的节日 
  
  
'PublicwFtv(1To30)AsString'西方的节日 
  
  

  
  
PublicSubSetValue() 
  
  
DimiAsInteger
  
  

  
  
'阳历节日：前四位数字为阳历的MMDD（月日），后面的文字为意义 
  
  
sFtv(1)="0101元旦"
  
  
sFtv(2)="0214情人节"
  
  
sFtv(3)="0308妇女节"
  
  
sFtv(4)="0312植树节"
  
  
sFtv(5)="0315权益日"
  
  
sFtv(6)="0401愚人节"
  
  
sFtv(7)="0501劳动节"
  
  
sFtv(8)="0504青年节"
  
  
sFtv(9)="0512护士节"
  
  
sFtv(10)="0601儿童节"
  
  
sFtv(11)="0701建党节"
  
  
sFtv(12)="0801建军节"
  
  
sFtv(13)="0808父亲节"
  
  
sFtv(14)="0910教师节"
  
  
sFtv(15)="1001国庆节"
  
  
sFtv(16)="1006老人节"
  
  
sFtv(17)="1225圣诞节"
  
  

  
  
'农历的节日：日期表示的是农历的某月某日 
  
  

  
  
lFtv(1)="0101春节"
  
  
lFtv(2)="0115元宵节"
  
  
lFtv(3)="0505端午节"
  
  
lFtv(4)="0707七夕节"
  
  
lFtv(5)="0715中元节"
  
  
lFtv(6)="0815中秋节"
  
  
lFtv(7)="0909重阳节"
  
  
lFtv(8)="1208腊八节"
  
  
lFtv(9)="1224小年"
  
  
lFtv(10)="0100除夕"
  
  

  
  
'wFtv(1)="" 
  
  
'wFtv(2)="0231总统日" 
  
  
'wFtv(3)="0520母亲节" 
  
  
'wFtv(4)="" 
  
  
'wFtv(5)="0531胜利日" 
  
  
'wFtv(6)="0716合作节" 
  
  
'wFtv(7)="0730被奴周" 
  
  
'wFtv(8)="" 
  
  
'wFtv(9)="" 
  
  
'wFtv(10)="1021哥伦布日" 
  
  
'wFtv(11)="1144感恩节" 
  
  

  
  
'******************** 
  
  

  
  
LunarInfo(1)=&H4BD8 
  
  
LunarInfo(2)=&H4AE0 
  
  
LunarInfo(3)=&HA570 
  
  
LunarInfo(4)=&H54D5 
  
  
LunarInfo(5)=&HD260 
  
  
LunarInfo(6)=&HD950 
  
  
LunarInfo(7)=&H16554 
  
  
LunarInfo(8)=&H56A0 
  
  
LunarInfo(9)=&H9AD0 
  
  
LunarInfo(10)=&H55D2 
  
  
LunarInfo(11)=&H4AE0 
  
  
LunarInfo(12)=&HA5B6 
  
  
LunarInfo(13)=&HA4D0 
  
  
LunarInfo(14)=&HD250 
  
  
LunarInfo(15)=&H1D255 
  
  
LunarInfo(16)=&HB540 
  
  
LunarInfo(17)=&HD6A0 
  
  
LunarInfo(18)=&HADA2 
  
  
LunarInfo(19)=&H95B0 
  
  
LunarInfo(20)=&H14977 
  
  
LunarInfo(21)=&H4970 
  
  
LunarInfo(22)=&HA4B0 
  
  
LunarInfo(23)=&HB4B5 
  
  
LunarInfo(24)=&H6A50 
  
  
LunarInfo(25)=&H6D40 
  
  
LunarInfo(26)=&H1AB54 
  
  
LunarInfo(27)=&H2B60 
  
  
LunarInfo(28)=&H9570 
  
  
LunarInfo(29)=&H52F2 
  
  
LunarInfo(30)=&H4970 
  
  
LunarInfo(31)=&H6566 
  
  
LunarInfo(32)=&HD4A0 
  
  
LunarInfo(33)=&HEA50 
  
  
LunarInfo(34)=&H6E95 
  
  
LunarInfo(35)=&H5AD0 
  
  
LunarInfo(36)=&H2B60 
  
  
LunarInfo(37)=&H186E3 
  
  
LunarInfo(38)=&H92E0 
  
  
LunarInfo(39)=&H1C8D7 
  
  
LunarInfo(40)=&HC950 
  
  
LunarInfo(41)=&HD4A0 
  
  
LunarInfo(42)=&H1D8A6 
  
  
LunarInfo(43)=&HB550 
  
  
LunarInfo(44)=&H56A0 
  
  
LunarInfo(45)=&H1A5B4 
  
  
LunarInfo(46)=&H25D0 
  
  
LunarInfo(47)=&H92D0 
  
  
LunarInfo(48)=&HD2B2 
  
  
LunarInfo(49)=&HA950 
  
  
LunarInfo(50)=&HB557 
  
  
LunarInfo(51)=&H6CA0 
  
  
LunarInfo(52)=&HB550 
  
  
LunarInfo(53)=&H15355 
  
  
LunarInfo(54)=&H4DA0 
  
  
LunarInfo(55)=&HA5D0 
  
  
LunarInfo(56)=&H14573 
  
  
LunarInfo(57)=&H52D0 
  
  
LunarInfo(58)=&HA9A8 
  
  
LunarInfo(59)=&HE950 
  
  
LunarInfo(60)=&H6AA0 
  
  
LunarInfo(61)=&HAEA6 
  
  
LunarInfo(62)=&HAB50 
  
  
LunarInfo(63)=&H4B60 
  
  
LunarInfo(64)=&HAAE4 
  
  
LunarInfo(65)=&HA570 
  
  
LunarInfo(66)=&H5260 
  
  
LunarInfo(67)=&HF263 
  
  
LunarInfo(68)=&HD950 
  
  
LunarInfo(69)=&H5B57 
  
  
LunarInfo(70)=&H56A0 
  
  
LunarInfo(71)=&H96D0 
  
  
LunarInfo(72)=&H4DD5 
  
  
LunarInfo(73)=&H4AD0 
  
  
LunarInfo(74)=&HA4D0 
  
  
LunarInfo(75)=&HD4D4 
  
  
LunarInfo(76)=&HD250 
  
  
LunarInfo(77)=&HD558 
  
  
LunarInfo(78)=&HB540 
  
  
LunarInfo(79)=&HB5A0 
  
  
LunarInfo(80)=&H195A6 
  
  
LunarInfo(81)=&H95B0 
  
  
LunarInfo(82)=&H49B0 
  
  
LunarInfo(83)=&HA974 
  
  
LunarInfo(84)=&HA4B0 
  
  
LunarInfo(85)=&HB27A 
  
  
LunarInfo(86)=&H6A50 
  
  
LunarInfo(87)=&H6D40 
  
  
LunarInfo(88)=&HAF46 
  
  
LunarInfo(89)=&HAB60 
  
  
LunarInfo(90)=&H9570 
  
  
LunarInfo(91)=&H4AF5 
  
  
LunarInfo(92)=&H4970 
  
  
LunarInfo(93)=&H64B0 
  
  
LunarInfo(94)=&H74A3 
  
  
LunarInfo(95)=&HEA50 
  
  
LunarInfo(96)=&H6B58 
  
  
LunarInfo(97)=&H55C0 
  
  
LunarInfo(98)=&HAB60 
  
  
LunarInfo(99)=&H96D5 
  
  
LunarInfo(100)=&H92E0 
  
  
LunarInfo(101)=&HC960 
  
  
LunarInfo(102)=&HD954 
  
  
LunarInfo(103)=&HD4A0 
  
  
LunarInfo(104)=&HDA50 
  
  
LunarInfo(105)=&H7552 
  
  
LunarInfo(106)=&H56A0 
  
  
LunarInfo(107)=&HABB7 
  
  
LunarInfo(108)=&H25D0 
  
  
LunarInfo(109)=&H92D0 
  
  
LunarInfo(110)=&HCAB5 
  
  
LunarInfo(111)=&HA950 
  
  
LunarInfo(112)=&HB4A0 
  
  
LunarInfo(113)=&HBAA4 
  
  
LunarInfo(114)=&HAD50 
  
  
LunarInfo(115)=&H55D9 
  
  
LunarInfo(116)=&H4BA0 
  
  
LunarInfo(117)=&HA5B0 
  
  
LunarInfo(118)=&H15176 
  
  
LunarInfo(119)=&H52B0 
  
  
LunarInfo(120)=&HA930 
  
  
LunarInfo(121)=&H7954 
  
  
LunarInfo(122)=&H6AA0 
  
  
LunarInfo(123)=&HAD50 
  
  
LunarInfo(124)=&H5B52 
  
  
LunarInfo(125)=&H4B60 
  
  
LunarInfo(126)=&HA6E6 
  
  
LunarInfo(127)=&HA4E0 
  
  
LunarInfo(128)=&HD260 
  
  
LunarInfo(129)=&HEA65 
  
  
LunarInfo(130)=&HD530 
  
  
LunarInfo(131)=&H5AA0 
  
  
LunarInfo(132)=&H76A3 
  
  
LunarInfo(133)=&H96D0 
  
  
LunarInfo(134)=&H4BD7 
  
  
LunarInfo(135)=&H4AD0 
  
  
LunarInfo(136)=&HA4D0 
  
  
LunarInfo(137)=&H1D0B6 
  
  
LunarInfo(138)=&HD250 
  
  
LunarInfo(139)=&HD520 
  
  
LunarInfo(140)=&HDD45 
  
  
LunarInfo(141)=&HB5A0 
  
  
LunarInfo(142)=&H56D0 
  
  
LunarInfo(143)=&H55B2 
  
  
LunarInfo(144)=&H49B0 
  
  
LunarInfo(145)=&HA577 
  
  
LunarInfo(146)=&HA4B0 
  
  
LunarInfo(147)=&HAA50 
  
  
LunarInfo(148)=&H1B255 
  
  
LunarInfo(149)=&H6D20 
  
  
LunarInfo(150)=&HADA0 
  
  
 
  
  
LunarInfo(151)=&H14B63 
  
  
LunarInfo(152)=&H9370 
  
  
LunarInfo(153)=&H49F8 
  
  
LunarInfo(154)=&H4970 
  
  
LunarInfo(155)=&H64B0 
  
  
LunarInfo(156)=&H168A6 
  
  
LunarInfo(157)=&HEA50 
  
  
LunarInfo(158)=&H6B20 
  
  
LunarInfo(159)=&H1A6C4 
  
  
LunarInfo(160)=&HAAE0 
  
  
LunarInfo(161)=&H92E0 
  
  
LunarInfo(162)=&HD2E3 
  
  
LunarInfo(163)=&HC960 
  
  
LunarInfo(164)=&HD557 
  
  
LunarInfo(165)=&HD4A0 
  
  
LunarInfo(166)=&HDA50 
  
  
LunarInfo(167)=&H5D55 
  
  
LunarInfo(168)=&H56A0 
  
  
LunarInfo(169)=&HA6D0 
  
  
LunarInfo(170)=&H55D4 
  
  
LunarInfo(171)=&H52D0 
  
  

  
  
LunarInfo(172)=&HA9B8 
  
  
LunarInfo(173)=&HA950 
  
  
LunarInfo(174)=&HB4A0 
  
  
LunarInfo(175)=&HB6A6 
  
  
LunarInfo(176)=&HAD50 
  
  
LunarInfo(177)=&H55A0 
  
  
LunarInfo(178)=&HABA4 
  
  
LunarInfo(179)=&HA5B0 
  
  
LunarInfo(180)=&H52B0 
  
  
LunarInfo(181)=&HB273 
  
  

  
  
LunarInfo(182)=&H6930 
  
  
LunarInfo(183)=&H7337 
  
  
LunarInfo(184)=&H6A60 
  
  
LunarInfo(185)=&HAD50 
  
  
LunarInfo(186)=&H6B55 
  
  
LunarInfo(187)=&H4B60 
  
  
LunarInfo(188)=&HA570 
  
  
LunarInfo(189)=&H54E4 
  
  
LunarInfo(190)=&HD160 
  
  
LunarInfo(191)=&HE968 
  
  

  
  

  
  
Dims1,s2,s3,s4,s5,s6,s7AsString
  
  
s1="甲乙丙丁戊己庚辛壬癸"
  
  
s2="子丑寅卯辰巳午未申酉戌亥"
  
  
s3="鼠牛虎兔龙蛇马羊猴鸡狗猪"
  
  
s4="小寒大寒立春雨水惊蛰春分清明谷雨立夏小满芒种夏至小暑大暑立秋处暑白露秋分寒露霜降立冬小雪大雪冬至"
  
  
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"
  
  
s6="一二三四五六七八九十日"
  
  
s7="初十廿卅　"
  
  

  
  
Fori=1To24 
  
  
Ifi<=10ThenGan(i)=Mid(s1,i,1) 
  
  
Ifi<=12Then
  
  
Zhi(i)=Mid(s2,1) 
  
  
Animals(i)=Mid(s3,1) 
  
  
EndIf
  
  
SolarTerm(i)=Mid(s4,(i-1)*2+1,2) 
  
  
sTermInfo(i)=Val(Mid(s5,(i-1)*7+1,6)) 
  
  
Ifi<=11ThennStr1(i)=Mid(s6,1) 
  
  
Ifi<=5ThennStr2(i)=Mid(s7,1) 
  
  
Nexti 
  
  

  
  
EndSub
  
  

  
  

  
  
'************************************** 
  
  

  
  
'日历系统中的常用处理函数 
  
  

  
  
'************************************** 
  
  

  
  
'传回农历y年m月的总天数 
  
  

  
  
FunctionlMonthDays(ByValYAsInteger,ByValmAsInteger)AsInteger
  
  
IfY<1900ThenY=1900 
  
  
If(LunarInfo(Y-1900+1)AndInt(&H10000/(2^m)))=0Then
  
  
lMonthDays=29 
  
  
Else
  
  
lMonthDays=30 
  
  
EndIf
  
  
EndFunction
  
  

  
  

  
  
'传回农历y年闰哪个月1-12,没闰传回0 
  
  

  
  
FunctionLeapMonth(ByValYAsInteger)AsInteger
  
  
LeapMonth=0 
  
  
IfY>=1900ThenLeapMonth=(LunarInfo(Y-1900+1)And&HF) 
  
  
EndFunction
  
  

  
  

  
  
'传回农历y年闰月的天数 
  
  

  
  
FunctionLeapDays(ByValYAsInteger)AsInteger
  
  
DimmAsInteger
  
  
DimlAsDouble
  
  
m=LeapMonth(Y) 
  
  
Ifm=0Then
  
  
LeapDays=0 
  
  
Else
  
  
l=LunarInfo(Y-1900+1) 
  
  
Ifl<0Thenl=l*(-1) 
  
  
l=(lAnd&H10000) 
  
  
Ifl=0Then
  
  
LeapDays=29 
  
  
Else
  
  
LeapDays=30 
  
  
EndIf
  
  
EndIf
  
  
EndFunction
  
  

  
  

  
  
'传回农历y年的总天数 
  
  

  
  
FunctionlYearDays(ByValYAsInteger)AsInteger
  
  
Dimi,SumAsDouble
  
  
Sum=0 
  
  
Fori=1To12 
  
  
Sum=Sum+lMonthDays(Y,i) 
  
  
Nexti 
  
  
lYearDays=Sum+LeapDays(Y) 
  
  
EndFunction
  
  

  
  

  
  
'传回阳历y年某m月的天数 
  
  

  
  
'FunctionSolarDays(ByValYAsInteger,ByValmAsInteger)AsInteger 
  
  
'Ifm=2Then 
  
  
'If(YMod4=0AndYMod100<>0)Or(YMod400=0)Then 
  
  
'SolarDays=29 
  
  
'Else 
  
  
'SolarDays=28 
  
  
'EndIf 
  
  
'Else 
  
  
'SolarDays=SolarMonth(m) 
  
  
'EndIf 
  
  
'EndFunction 
  
  

  
  

  
  
'根据给定的阳历，返回农历的日期 
  
  

  
  
FunctionGetLunar(ByValSolarDateAsDate)AsString
  
  
DimDaysOffsetAsLong
  
  
DimiAsInteger
  
  
DimTempAsLong
  
  
Dimlyear,lmonth,ldayAsInteger
  
  

  
  
'///////////////////////////////////////////////// 
  
  
IfSolarDate<=CDate("2000-2-5")Then
  
  
DaysOffset=SolarDate-CDate("1900-1-31") 
  
  
i=1900 
  
  
DoWhilei<2001AndDaysOffset>=0 
  
  
Temp=lYearDays(i) 
  
  
DaysOffset=DaysOffset-Temp 
  
  
i=i+1 
  
  
Loop
  
  
IfDaysOffset<0Then
  
  
DaysOffset=DaysOffset+Temp 
  
  
i=i-1 
  
  
EndIf
  
  
lyear=i 
  
  
Else
  
  
DaysOffset=SolarDate-CDate("2000-2-5") 
  
  
i=2000 
  
  
DoWhilei<2091AndDaysOffset>=0 
  
  
Temp=lYearDays(i) 
  
  
DaysOffset=DaysOffset-Temp 
  
  
i=i+1 
  
  
Loop
  
  
IfDaysOffset<0Then
  
  
DaysOffset=DaysOffset+Temp 
  
  
i=i-1 
  
  
EndIf
  
  
lyear=i 
  
  
EndIf
  
  

  
  
'//////////////////////////////////////////////////// 
  
  

  
  
DimLeapAsInteger
  
  
DimIsLeapAsBoolean
  
  
Leap=LeapMonth(i) 
  
  
IsLeap=False
  
  
i=1 
  
  
DoWhilei<13AndDaysOffset>0 
  
  
IfLeap>0Andi=(Leap+1)AndIsLeap=FalseThen
  
  
i=i-1 
  
  
IsLeap=True
  
  
Temp=LeapDays(lyear) 
  
  
Else
  
  
Temp=lMonthDays(lyear,i) 
  
  
EndIf
  
  
IfIsLeapAndi=(Leap+1)ThenIsLeap=False
  
  
DaysOffset=DaysOffset-Temp 
  
  
i=i+1 
  
  
Loop
  
  

  
  
IfDaysOffset=0AndLeap>0Andi=Leap+1Then
  
  
IfIsLeapThen
  
  
IsLeap=False
  
  
Else
  
  
IsLeap=True
  
  
i=i-1 
  
  
EndIf
  
  
EndIf
  
  
IfDaysOffset<0Then
  
  
DaysOffset=DaysOffset+Temp 
  
  
i=i-1 
  
  
EndIf
  
  
lmonth=i 
  
  
lday=DaysOffset+1 
  
  
'返回特殊标志的字符串 
  
  
IfIsLeapThen
  
  
GetLunar="1"&Format(lyear,"0000")&Format(lmonth,"00")&Format(lday,"00") 
  
  
Else
  
  
GetLunar="0"&Format(lyear,"00") 
  
  
EndIf
  
  

  
  
EndFunction
  
  

  
  

  
  
'将年份用天干地支表示 
  
  
PublicFunctionGanZhi(ByValsyearAsInteger)AsString
  
  
DimstrGan,strZhiAsString
  
  

  
  
strGan=Gan((syear-1900+6)Mod10+1) 
  
  
strZhi=Zhi((syear-1900+12)Mod12+1) 
  
  
GanZhi=strGan+strZhi+"年"
  
  

  
  
EndFunction
  
  

  
  

  
  
'将月份用农历表示 
  
  
PublicFunctionCnMonth(ByValsmonthAsInteger)AsString
  
  

  
  
Ifsmonth<10Then
  
  
CnMonth=nStr1(smonth)+"月"
  
  
ElseIfsmonth=10Then
  
  
CnMonth="十"+"月"
  
  
Else
  
  
CnMonth="十"+nStr1(smonthMod10)+"月"
  
  
EndIf
  
  
EndFunction
  
  

  
  

  
  
'将日用农历表示 
  
  
PublicFunctionCnDay(ByValsdayAsInteger)AsString
  
  
Ifsday<=10Then
  
  
CnDay="初"+nStr1(sday) 
  
  
ElseIfsday<20Then
  
  
CnDay="十"+nStr1(sdayMod10) 
  
  
ElseIfsday=20Then
  
  
CnDay="廿十"
  
  
ElseIfsday<30Then
  
  
CnDay="廿"+nStr1(sdayMod10) 
  
  
Else
  
  
CnDay="卅十"
  
  
EndIf
  
  
EndFunction
  
  

  
  
'根据年份返回属象 
  
  
PublicFunctionAnimal(ByValsyearAsInteger)AsString
  
  
Animal=Animals((syear-1900)Mod12+1) 
  
  
EndFunction
  
  

  
  

  
  
'某y年的第n个节气的日期(从1小寒起算) 
  
  
FunctionsTerm(ByValY,nAsInteger)AsDate
  
  
DimD1,D2AsDouble
  
  
D1=(31556925.9747*(Y-1900)+sTermInfo(n)*60#) 
  
  
D2=DateDiff("s","1970-1-10:0","1900-1-62:5")+D1 
  
  
D1=D2/2 
  
  
sTerm=DateAdd("s",D2-D1,DateAdd("s",D1,"1970-1-10:0")) 
  
  
sTerm=Format(sTerm,"yyyy/mm/dd") 
  
  
EndFunction
  
  

  
  

  
  
'根据阳历返回其节气，若不是则返回空 
  
  
PublicFunctionGetTerm(ByValsDateAsDate)AsString
  
  
DimY,mAsInteger
  
  
Y=Year(sDate) 
  
  
m=Month(sDate) 
  
  
GetTerm=""
  
  
IfsTerm(Y,m*2-1)=sDateThen
  
  
GetTerm=SolarTerm(m*2-1) 
  
  
ElseIfsTerm(Y,m*2)=sDateThen
  
  
GetTerm=SolarTerm(m*2) 
  
  
EndIf
  
  
EndFunction
  
  
'返回阳历是该月的第几个星期几的字符串，如:0520表示5月份第2个星期日 
  
  

  
  
FunctionGetMonthWeek(ByValsDateAsDate)AsString
  
  
DimD0AsDate
  
  
D0=CDate(Year(sDate)&"-"&Month(sDate)&"-1") 
  
  
GetMonthWeek=Format(Month(sDate),"00")&(Int((Day(sDate)-1+Weekday(D0)-1)/7)+1)&Weekday(sDate)-1 
  
  
EndFunction
 
 

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!