VB计算农历的算法

'下面是一个关于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是设置是不是通过农历取公历值，如果是， 

'前三个返回相应的公历日期，而且返回值是一个公历日期。 

Function GetYLDate(tYear As Integer, tMonth As Integer, tDay As Integer, _ 

          YLyear As String, YLShuXing As String, _ 

          Optional IsGetGl As Boolean) As String 

  On Error Resume Next 

  Dim daList(1900 To 2011) As String * 18 

  Dim conDate As Date, setDate As Date 

  Dim AddMonth As Integer, AddDay As Integer, AddYear As Integer, getDay As Integer 

  Dim RunYue As Boolean 

  If tYear > 2010 Or tYear < 1901 Then Exit Function '如果不是有效有日期，退出 

  '1900 to 1909 

  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 

   

  If IsGetGl Then 

    AddMonth = Val(Mid(daList(AddYear), 15, 2)) 

    AddDay = Val(Mid(daList(AddYear), 17, 2)) 

    conDate = DateSerial(AddYear, AddMonth, AddDay) 

    AddDay = tDay 

    For i = 1 To tMonth - 1 

      AddDay = AddDay + 29 + Val(Mid(daList(tYear), i, 1)) 

    Next i 

    'MsgBox DateDiff("d", conDate, Date) 

    setDate = DateAdd("d", AddDay - 1, conDate) 

    GetYLDate = setDate 

    tYear = Year(setDate) 

    tMonth = Month(setDate) 

    tDay = Day(setDate) 

    Exit Function 

  End If 

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) 

  If getDay < 0 Then AddYear = AddYear - 1: GoTo CHUSHIHUA 

  ' addday = NearDay 

  AddDay = 1: AddMonth = 1 

  For i = 1 To getDay 

    AddDay = AddDay + 1 

    If AddDay = 30 + Mid(daList(AddYear), AddMonth, 1) Or (RunYue And AddDay = 30 + Mid(daList(AddYear), 13, 1)) Then 

      If RunYue = False And AddMonth = Val("&H" & Mid(daList(AddYear), 14, 1)) Then 

        RunYue = True 

      Else 

        RunYue = False 

        AddMonth = AddMonth + 1 

      End If 

      AddDay = 1 

    End If 

     

  Next 

 

  md$ = "初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十" 

  dd$ = Mid(md$, (AddDay - 1) * 2 + 1, 2) 

  mm$ = Mid("正二三四五六七八九十寒腊", AddMonth, 1) + "月" 

  YouGetDate = DateSerial(AddYear, AddMonth, AddDay) 

  tiangan$ = "甲乙丙丁戊已庚辛壬癸" 

  dizhi$ = "子丑寅卯辰巳午未申酉戌亥" 

  Dim ganzhi(0 To 59) As String * 2 

  For i = 0 To 59 

   ganzhi(i) = Mid(tiangan$, (i Mod 10) + 1, 1) + Mid(dizhi$, (i Mod 12) + 1, 1) 

  'ff$ = ff$ + ganzhi(i) 

  Next i 

  'MsgBox ff$, , Len(ff$) 

  YLyear = ganzhi((AddYear - 4) Mod 60) 

  shu$ = "鼠牛虎兔龙蛇马羊猴鸡狗猪" 

  YLShuXing = Mid(shu$, ((AddYear - 4) Mod 12) + 1, 1) 

  If RunYue Then mm$ = "闰" + mm$ 

   

  GetYLDate = mm$ + dd$ 

End Function 

'下面是一个使用的例子，你需要在窗体上加上一个按扭，并命名为Command1，然后将下列代码复制到窗体的代码中 

Private Sub Command1_Click() 

  Dim ty As Integer, tm As Integer, td As Integer, yl As String, sx As String 

  '取公历1999年10月28日的农历日期 

  ty = 1999 

  tm = 10 

  td = 28 

  t = GetYLDate(ty, tm, td, yl, sx) 

  MsgBox t 

  MsgBox ty & "-" & tm & "-" & td & " " & yl & " " & sx 

  '取1999年农历十月28的公历日期 

  t = GetYLDate(ty, tm, td, yl, sx, True) 

  MsgBox t 

  MsgBox ty & "-" & tm & "-" & td & " " & yl & " " & sx 

   

End Sub

本文地址：http://com.8s8s.com/it/it43105.htm