'下面是一個關於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，然後將下列代碼復制到窗體的代碼中
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->
