分享
 
 
 

VB计算农历的算法

王朝vb·作者佚名  2006-01-08
窄屏简体版  字體: |||超大  

'下面是一个关于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

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有