'下面是一个关于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)
IfgetDay<0ThenAddYear=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，然后将下s代码复制到窗体的代码中
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年农0十月28的公历日期
t=GetYLDate(ty,tm,td,yl,sx,True)
MsgBoxt
MsgBoxty&"-"&tm&"-"&td&""&yl&""&sx
EndSub->
