VB编程计算农历的计算方法

【 tulaoshi.com - 编程语言 】

'下面是一个关于VB的农历算法
　　
　　'日期数据定义方法如下
　　
　　'前12个字节代表1-12月为大月或是小月，1为大月30天，0为小月29天，
　　
　　'第13位为闰月的情况，1为大月30天，0为小月29天，第14位为闰月的月
　　
　　'份，如果不是闰月为0，否则给出月份，10、11、12分别用A、B、C来表
　　
　　'示，即使用16进制。最后4位为当年家农历新年-即农历1月1日所在公历
　　
　　'的日期，如0131代表1月31日。
　　
　　'GetYLDate函数使用方式如下tYear为要输入的年，tMonth为月，tDay为
　　
　　'日期，YLyear是返回值，返加农历的年份，如甲子年，YLShuXing返回
　　
　　'的是属象，如鼠。IsGetGl是设置是不是通过农历取公历值，如果是，
　　
　　'前三个返回相应的公历日期，而且返回值是一个公历日期。
　　
　　
　　FunctionGetYLDate(tYearAsInteger,tMonthAsInteger,tDayAsInteger,_
　　
　　YLyearAsString,YLShuXingAsString,_
　　
　　OptionalIsGetGlAsBoolean)AsString
　　
　　
　　OnErrorResumeNext
　　
　　DimdaList(1900To2011)AsString*18
　　
　　DimconDateAsDate,setDateAsDate
　　
　　DimAddMonthAsInteger,AddDayAsInteger,AddYearAsInteger,getDayAsInteger
　　
　　DimRunYueAsBoolean
　　
　　IftYear＞2010OrtYear＜1901ThenExitFunction'如果不是有效有日期，退出
　　
　　'1900to1909
　　
　　daList(1900)="010010110110180131"
　　
　　daList(1901)="010010101110000219"
　　
　　daList(1902)="101001010111000208"
　　
　　daList(1903)="010100100110150129"
　　
　　daList(1904)="110100100110000216"
　　
　　daList(1905)="110110010101000204"
　　
　　daList(1906)="011010101010140125"
　　
　　daList(1907)="010101101010000213"
　　
　　daList(1908)="100110101101000202"
　　
　　daList(1909)="010010101110120122"
　　
　　daList(1910)="010010101110000210"
　　
　　daList(1911)="101001001101160130"
　　
　　daList(1912)="101001001101000218"
　　
　　daList(1913)="110100100101000206"
　　
　　daList(1914)="110101010100150126"
　　
　　daList(1915)="101101010101000214"
　　
　　daList(1916)="010101101010000204"
　　
　　daList(1917)="100101101101020123"
　　
　　daList(1918)="100101011011000211"
　　
　　daList(1919)="010010011011170201"
　　
　　daList(1920)="010010011011000220"
　　
　　daList(1921)="101001001011000208"
　　
　　daList(1922)="101100100101150128"
　　
　　daList(1923)="011010100101000216"
　　
　　daList(1924)="011011010100000205"
　　
　　daList(1925)="101011011010140124"
　　
　　daList(1926)="001010110110000213"
　　
　　daList(1927)="100101010111000202"
　　
　　daList(1928)="010010010111120123"
　　
　　daList(1929)="010010010111000210"
　　
　　daList(1930)="011001001011060130"
　　
　　daList(1931)="110101001010000217"
　　
　　daList(1932)="111010100101000206"
　　
　　daList(1933)="011011010100150126"
　　
　　daList(1934)="010110101101000214"
　　
　　daList(1935)="001010110110000204"
　　
　　daList(1936)="100100110111030124"
　　
　　daList(1937)="100100101110000211"
　　
　　daList(1938)="110010010110170131"
　　
　　daList(1939)="110010010101000219"
　　
　　daList(1940)="110101001010000208"
　　
　　daList(1941)="110110100101060127"
　　
　　daList(1942)="101101010101000215"
　　
　　daList(1943)="010101101010000205"
　　
　　daList(1944)="101010101101140125"
　　
　　daList(1945)="001001011101000213"
　　
　　daList(1946)="100100101101000202"
　　
　　daList(1947)="110010010101120122"
　　
　　daList(1948)="101010010101000210"
　　
　　daList(1949)="101101001010170129"
　　
　　daList(1950)="011011001010000217"
　　
　　daList(1951)="101101010101000206"
　　
　　daList(1952)="010101011010150127"
　　
　　daList(1953)="010011011010000214"
　　
　　daList(1954)="101001011011000203"
　　
　　daList(1955)="010100101011130124"
　　
　　daList(1956)="010100101011000212"
　　
　　daList(1957)="101010010101080131"
　　
　　daList(1958)="111010010101000218"
　　
　　daList(1959)="011010101010000208"
　　
　　daList(1960)="101011010101060128"
　　
　　daList(1961)="101010110101000215"
　　
　　daList(1962)="010010110110000205"
　　
　　daList(1963)="101001010111040125"
　　
　　daList(1964)="101001010111000213"
　　
　　daList(1965)="010100100110000202"
　　
　　daList(1966)="111010010011030121"
　　
　　daList(1967)="110110010101000209"
　　
　　daList(1968)="010110101010170130"
　　
　　daList(1969)="010101101010000217"
　　
　　daList(1970)="100101101101000206"
　　
　　daList(1971)="010010101110150127"
　　
　　daList(1972)="010010101101000215"
　　
　　daList(1973)="101001001101000203"
　　
　　daList(1974)="110100100110140123"
　　
　　daList(1975)="110100100101000211"
　　
　　daList(1976)="110101010010180131"
　　
　　daList(1977)="101101010100000218"
　　
　　daList(1978)="101101101010000207"
　　
　　daList(1979)="100101101101060128"
　　
　　daList(1980)="100101011011000216"
　　
　　daList(1981)="010010011011000205"
　　
　　daList(1982)="101001001011140125"
　　
　　daList(1983)="101001001011000213"
　　
　　daList(1984)="1011001001011A0202"
　　
　　daList(1985)="011010100101000220"
　　
　　daList(1986)="011011010100000209"
　　
　　daList(1987)="101011011010060129"
　　
　　daList(1988)="101010110110000217"
　　
　　daList(1989)="100100110111000206"
　　
　　daList(1990)="010010010111150127"
　　
　　daList(1991)="010010010111000215"
　　
　　daList(1992)="011001001011000204"
　　
　　daList(1993)="011010100101030123"
　　
　　daList(1994)="111010100101000210"
　　
　　daList(1995)="011010110010180131"
　　
　　daList(1996)="010110101100000219"
　　
　　daList(1997)="101010110110000207"
　　
　　daList(1998)="100100110110150128"
　　
　　daList(1999)="100100101110000216"
　　
　　daList(2000)="110010010110000205"
　　
　　daList(2001)="110101001010140124"
　　
　　daList(2002)="110101001010000212"
　　
　　daList(2003)="110110100101000201"
　　
　　daList(2004)="010110101010120122"
　　
　　daList(2005)="010101101010000209"
　　
　　daList(2006)="101010101101170129"
　　
　　daList(2007)="001001011101000218"
　　
　　daList(2008)="100100101101000207"
　　
　　daList(2009)="110010010101150126"
　　
　　daList(2010)="101010010101000214"
　　
　　daList(2011)="101101001010000214"
　　
　　AddYear=tYear
　　
　　RunYue=False
　　
　　
　　
　　IfIsGetGlThen
　　
　　AddMonth=Val(Mid(daList(AddYear),15,2))
　　
　　AddDay=Val(Mid(daList(AddYear),17,2))
　　
　　conDate=DateSerial(AddYear,AddMonth,AddDay)
　　
　　AddDay=tDay
　　
　　Fori=1TotMonth-1
　　
　　AddDay=AddDay 29 Val(Mid(daList(tYear),i,1))
　　
　　Nexti
　　
　　'MsgBoxDateDiff("d",conDate,Date)
　　
　　setDate=DateAdd("d",AddDay-1,conDate)
　　
　　GetYLDate=setDate
　　
　　tYear=Year(setDate)
　　
　　tMonth=Month(setDate)
　　
　　tDay=Day(setDate)
　　
　　ExitFunction
　　
　　EndIf
　　
　　CHUSHIHUA:
　　
　　AddMonth=Val(Mid(daList(AddYear),15,2))
　　
　　AddDay=Val(Mid(daList(AddYear),17,2))
　　
　　conDate=DateSerial(AddYear,AddMonth,AddDay)
　　
　　setDate=DateSerial(tYear,tMonth,tDay)
　　
　　getDay=DateDiff("d",conDate,setDate)
　　
　　IfgetDay0ThenAddYear=AddYear-1:GoToCHUSHIHUA
　　
　　'addday=NearDay
　　
　　AddDay=1:AddMonth=1
　　
　　Fori=1TogetDay
　　
　　AddDay=AddDay 1
　　
　　IfAddDay=30 Mid(daList(AddYear),AddMonth,1)Or(RunYueAndAddDay=30 Mid(daList(AddYear),13,1))Then
　　
　　IfRunYue=FalseAndAddMonth=Val("&H"&Mid(daList(AddYear),14,1))Then
　　
　　RunYue=True
　　
　　Else
　　
　　RunYue=False
　　
　　AddMonth=AddMonth 1
　　
　　EndIf
　　
　　AddDay=1
　　
　　EndIf
　　
　　
　　
　　Next
　　
　　
　　
　　md$="初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十"
　　
　　dd$=Mid(md$,(AddDay-1)*2 1,2)
　　
　　mm$=Mid("正二三四五六七八九十寒腊",AddMonth,1) "月"
　　
　　YouGetDate=DateSerial(AddYear,AddMonth,AddDay)
　　
　　tiangan$="甲乙丙丁戊已庚辛壬癸"
　　
　　dizhi$="子丑寅卯辰巳午未申酉戌亥"
　　
　　Dimganzhi(0To59)AsString*2
　　
　　Fori=0To59
　　
　　ganzhi(i)=Mid(tiangan$,(iMod10) 1,1) Mid(dizhi$,(iMod12) 1,1)
　　
　　'ff$=ff$ ganzhi(i)
　　
　　Nexti
　　
　　'MsgBoxff$,,Len(ff$)
　　
　　YLyear=ganzhi((AddYear-4)Mod60)
　　
　　shu$="鼠牛虎兔龙蛇马羊猴鸡狗猪"
　　
　　YLShuXing=Mid(shu$,((AddYear-4)Mod12) 1,1)
　　
　　IfRunYueThenmm$="闰" mm$
　　
　　
　　
　　GetYLDate=mm$ dd$
　　
　　
　　EndFunction
　　
　　
　　
　　'下面是一个使用的例子，你需要在窗体上加上一个按扭，并命名为Command1，然后将下列代码复制到窗体的代码中
　　
　　PrivateSubCommand1_Click()
　　
　　DimtyAsInteger,tmAsInteger,tdAsInteger,ylAsString,sxAsString
　　
　　'取公历1999年10月28日的农历日期
　　
　　ty=1999
　　
　　tm=10
　　
　　td=28
　　
　　t=GetYLDate(ty,tm,td,yl,sx)
　　
　　MsgBoxt
　　
　　MsgBoxty&"-"&tm&"-"&td&""&yl&""&sx
　　
　　'取1999年农历十月28的公历日期
　　
　　t=GetYLDate(ty,tm,td,yl,sx,True)
　　
　　MsgBoxt
　　
　　MsgBoxty&"-"&tm&"-"&td&""&yl&""&sx
　　
　　
　　
　　EndSub->