VB的农历算法(1900-2090)

概述从网上找到的VB农历代码收藏备用 Option Explicit     Public LunarInfo(1 To 191) As Double '从1900-2090年这150年的农历信息码     'Public SolarMonth(1 To 12) As Integer '阳历12个月的天数     Publ

从网上找到的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  

总结

以上是内存溢出为你收集整理的VB的农历算法(1900-2090)全部内容，希望文章能够帮你解决VB的农历算法(1900-2090)所遇到的程序开发问题。

如果觉得内存溢出网站内容还不错，欢迎将内存溢出网站推荐给程序员好友。