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