万年历的VB源代码

[nlucy]

请问一下谁有万年历VB的源代码，包括阴历的，谢谢！

[msn2005]

我晕，还以为你有呢。为什么不去搜索呢？

[泊客天涯]

"North Europe 北欧": { //----------------------------------------------
"Denmark 丹麦":["+0100","04F03|10L03","哥本哈根"],
"Finland 芬兰":["+0200","03L01|10L01","赫尔辛基"],
"Iceland 冰岛":["+0000","","雷克雅未克"],
"Norwegian 挪威":["+0100","","奥斯陆"],
"Sweden 瑞典":["+0100","03L01|10L01","斯德哥尔摩"]
},
"Eastern Europe 中欧、东欧": { //----------------------------------------
"Armenia 亚美尼亚":["+0400","","叶里温"],
"Austria 奥地利 ":["+0100","03L01|10L01","维也纳"],
"Azerbaijan 亚塞拜然":["+0400","","巴库"],
"Czech 捷克 ":["+0100","","布拉格"],
"Estonia 爱沙尼亚":["+0200","","塔林"],
"Germany 德国 ":["+0100","03L01|10L01","柏林"],
"Hungarian 匈牙利 ":["+0100","","布达佩斯"],
"Kazakhstan(Almaty) 哈萨克 ":["+0600","","Almaty"],
"Kazakhstan(Aqtobe) 哈萨克 ":["+0500","","Aqtobe"],
"Kazakhstan(Aqtau) 哈萨克 ":["+0400","","Aqtau"],
"Kirghizia 吉尔吉斯":["+0500","","比斯凯克"],
"Latvia 拉脱维亚":["+0200","","里加"],
"Lithuania 立陶宛 ":["+0200","","维尔纽斯"],
"Moldova 摩尔多瓦":["+0200","","基希涅夫"],
"Poland 波兰 ":["+0100","","华沙"],
"Rumania 罗马尼亚":["+0200","","布加勒斯特"],
"Russia(Moscow) 俄罗斯 ":["+0300","03L03|10L03","莫斯科"],
"Russia(Volgograd) 俄罗斯 ":["+0300","03L03|10L03","伏尔哥格勒"],
"Slovakia 斯洛伐克":["+0100","","布拉提斯拉瓦"],
"Switzerland 瑞士 ":["+0100","","苏黎世"],
"Ukraine 乌克兰 ":["+0200","","基辅"],
"Ukraine(Simferopol)乌克兰 ":["+0300","","Simferopol"],
"Belarus 白俄罗斯":["+0200","03L03|10L03","明斯克"]
},
"Western Europe 西欧": { //----------------------------------------------
"Belgium 比利时 ":["+0100","03L01|10L01","布鲁塞尔"],
"France 法国 ":["+0100","03L01|10L01","巴黎"],
"Ireland 爱尔兰 ":["+0000","03L01|10L01","都柏林"],
"Monaco 摩纳哥 ":["+0100","","摩纳哥市"],
"Netherlands 荷兰 ":["+0100","03L01|10L01","阿姆斯特丹"],
"Luxembourg 卢森堡 ":["+0100","03L01|10L01","卢森堡市"],
"United Kingdom 英国 ":["+0000","03L01|10L01","伦敦、爱丁堡"]
},
"South Europe 南欧": { //------------------------------------------------
"Albania 阿尔巴尼亚":["+0100","","地拉那"],
"Bulgaria 保加利亚":["+0200","","索菲亚"],
"Greece 希腊 ":["+0200","03L01|10L01","雅典"],
"Holy See 教廷 ":["+0100","","梵蒂冈"],
"Italy 义大利 ":["+0100","03L01|10L01","罗马"],
"Malta 马尔他 ":["+0100","","瓦勒他"],
"Portugal 葡萄牙 ":["+0000","03L01|10L01","里斯本"],
"San Marino 圣马利诺":["+0100","","圣马利诺"],
"Span 西班牙 ":["+0100","03L01|10L01","马德里"],
"Slovenia 斯洛维尼亚":["+0100","","卢布尔雅那"],
"Serbia(前南斯拉夫) 塞尔维亚":["+0100","","贝尔格勒"]
},
"North America 北美洲": { //--------------------------------------------
"Canada(NST) 加拿大":["-0330","04F02|10L02","纽芬兰、St. John's,Goose Bay"],
"Canada(AST) 加拿大":["-0400","04F02|10L02","Pangnirtung, Glace Bay"],
"Canada(EST) 加拿大":["-0500","04F02|10L02","蒙特娄"],
"Canada(CST) 加拿大":["-0600","04F02|10L02","Swift Current, Regina, Rainy River"],
"Canada(MST) 加拿大":["-0700","04F02|10L02","Inuvik, Edmonton, Dawson Creek"],
"Canada(PST) 加拿大":["-0800","04F02|10L02","温哥华"],
"US(Eastern) 美国(东岸)":["-0500","04F02|10L02","纽约"],
"US(Indiana) 美国 ":["-0500","","印第安纳"],
"US(Central) 美国(中部)":["-0600","04F02|10L02","芝加哥"],
"US(Mountain) 美国(山区)":["-0700","04F02|10L02","丹佛"],
"US(Arizona) 美国 ":["-0700","","亚历桑那"],
"US(Pacific) 美国(西岸)":["-0800","04F02|10L02","旧金山、洛杉矶"],
"US(Alaska) 美国 ":["-0900","","朱诺"]
},

[砸死牛顿的苹果]

好复杂哦
但是好像已经很精简了

[泊客天涯]

现在把万年历代码贴出来大家参考一下
这里还没加上二十四节气
大家努力加上完善一下然后大家分享一下
添加三个combobox控件
四个标签"年""月""日",其中一个caption为空name 为lb作为显示日期的容器
大家参考

'日期数据定义方法如下

'前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日。FunGetDate函数使用方式如下tYear为要输入的年，tMonth为月，tDay为

'日期，YLyear是返回值，返加农历的年份，如甲子年，YLShuXing返回的是属象，如鼠。IsGetGongLi是设置是不是通过农历取公历值，如果是，

'前三个返回相应的公历日期，而且返回值是一个公历日期。
'by lichangfeng [e-mail] 2007.4.5 5:30


Function FunGetDate(tYear As Integer, tMonth As Integer, tDay As Integer, YLyear As String, YLShuXing As String, Optional IsGetGongLi As Boolean) As String


On Error Resume Next

Dim dateList(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 2009

dateList(1900) = "010010110110180131"

dateList(1901) = "010010101110000219"

dateList(1902) = "101001010111000208"

dateList(1903) = "010100100110150129"

dateList(1904) = "110100100110000216"

dateList(1905) = "110110010101000204"

dateList(1906) = "011010101010140125"

dateList(1907) = "010101101010000213"

dateList(1908) = "100110101101000202"

dateList(1909) = "010010101110120122"

dateList(1910) = "010010101110000210"

dateList(1911) = "101001001101160130"

dateList(1912) = "101001001101000218"

dateList(1913) = "110100100101000206"

dateList(1914) = "110101010100150126"

dateList(1915) = "101101010101000214"

dateList(1916) = "010101101010000204"

dateList(1917) = "100101101101020123"

dateList(1918) = "100101011011000211"

dateList(1919) = "010010011011170201"

dateList(1920) = "010010011011000220"

dateList(1921) = "101001001011000208"

dateList(1922) = "101100100101150128"

dateList(1923) = "011010100101000216"

dateList(1924) = "011011010100000205"

dateList(1925) = "101011011010140124"

dateList(1926) = "001010110110000213"

dateList(1927) = "100101010111000202"

dateList(1928) = "010010010111120123"

dateList(1929) = "010010010111000210"

dateList(1930) = "011001001011060130"

dateList(1931) = "110101001010000217"

dateList(1932) = "111010100101000206"

dateList(1933) = "011011010100150126"

dateList(1934) = "010110101101000214"

dateList(1935) = "001010110110000204"

dateList(1936) = "100100110111030124"

dateList(1937) = "100100101110000211"

dateList(1938) = "110010010110170131"

dateList(1939) = "110010010101000219"

dateList(1940) = "110101001010000208"

dateList(1941) = "110110100101060127"

dateList(1942) = "101101010101000215"

dateList(1943) = "010101101010000205"

dateList(1944) = "101010101101140125"

dateList(1945) = "001001011101000213"

dateList(1946) = "100100101101000202"

dateList(1947) = "110010010101120122"

dateList(1948) = "101010010101000210"

dateList(1949) = "101101001010170129"

dateList(1950) = "011011001010000217"

dateList(1951) = "101101010101000206"

dateList(1952) = "010101011010150127"

dateList(1953) = "010011011010000214"

dateList(1954) = "101001011011000203"

dateList(1955) = "010100101011130124"

dateList(1956) = "010100101011000212"

dateList(1957) = "101010010101080131"

dateList(1958) = "111010010101000218"

dateList(1959) = "011010101010000208"

dateList(1960) = "101011010101060128"

dateList(1961) = "101010110101000215"

dateList(1962) = "010010110110000205"

dateList(1963) = "101001010111040125"

dateList(1964) = "101001010111000213"

dateList(1965) = "010100100110000202"

dateList(1966) = "111010010011030121"

dateList(1967) = "110110010101000209"

dateList(1968) = "010110101010170130"

dateList(1969) = "010101101010000217"

dateList(1970) = "100101101101000206"

dateList(1971) = "010010101110150127"

dateList(1972) = "010010101101000215"

dateList(1973) = "101001001101000203"

dateList(1974) = "110100100110140123"

dateList(1975) = "110100100101000211"

dateList(1976) = "110101010010180131"

dateList(1977) = "101101010100000218"

dateList(1978) = "101101101010000207"

dateList(1979) = "100101101101060128"

dateList(1980) = "100101011011000216"

dateList(1981) = "010010011011000205"

dateList(1982) = "101001001011140125"

dateList(1983) = "101001001011000213"

dateList(1984) = "1011001001011A0202"

dateList(1985) = "011010100101000220"

dateList(1986) = "011011010100000209"

dateList(1987) = "101011011010060129"

dateList(1988) = "101010110110000217"

dateList(1989) = "100100110111000206"

dateList(1990) = "010010010111150127"

dateList(1991) = "010010010111000215"

dateList(1992) = "011001001011000204"

dateList(1993) = "011010100101030123"

dateList(1994) = "111010100101000210"

dateList(1995) = "011010110010180131"

dateList(1996) = "010110101100000219"

dateList(1997) = "101010110110000207"

dateList(1998) = "100100110110150128"

dateList(1999) = "100100101110000216"

dateList(2000) = "110010010110000205"

dateList(2001) = "110101001010140124"

dateList(2002) = "110101001010000212"

dateList(2003) = "110110100101000201"

dateList(2004) = "010110101010120122"

dateList(2005) = "010101101010000209"

dateList(2006) = "101010101101170129"

dateList(2007) = "001001011101000218"

dateList(2008) = "100100101101000207"

dateList(2009) = "110010010101150126"

dateList(2010) = "101010010101000214"

dateList(2011) = "101101001010000214"

AddYear = tYear

RunYue = False

[泊客天涯]

If IsGetGongLi Then

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

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

conDate = DateSerial(AddYear, AddMonth, AddDay)

AddDay = tDay

For i = 1 To tMonth - 1

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

Next i

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

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

FunGetDate = setDate

tYear = Year(setDate)

tMonth = Month(setDate)

tDay = Day(setDate)

Exit Function

End If

CHUSHIHUA:

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

AddDay = Val(Mid(dateList(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(dateList(AddYear), AddMonth, 1) Or (RunYue And AddDay = 30 + Mid(dateList(AddYear), 13, 1)) Then

If RunYue = False And AddMonth = Val("&H" & Mid(dateList(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$



FunGetDate = mm$ + dd$


End Function

'添加三个combobox控件
'四个标签"年""月""日",其中一个caption为空name 为lb作为显示日期的容器

Private Sub Combo1_Click()

Dim ty As Integer, tm As Integer, td As Integer, yl As String, sx As String, yOn As Boolean
yOn = False
If Check1.Value = 1 Then
yOn = True
End If
lb.Caption = FunGetDate(Combo1.Text, Combo2.Text, Combo3.Text, yl, sx, yOn) & " " & yl & " " & sx


End Sub




Private Sub Combo2_Click()
com11 = Combo3.Text
Combo3.Clear
Select Case Combo2.Text
Case 1

For i = 1 To 31
Combo3.AddItem i, i - 1
Next
Case 2
If Combo1.Text Mod 4 <> 0 Then
For i = 1 To 28
Combo3.AddItem i, i - 1
Next
Else
For i = 1 To 29
Combo3.AddItem i, i - 1
Next
End If
Case 3
For i = 1 To 31
Combo3.AddItem i, i - 1
Next
Case 4

For i = 1 To 30
Combo3.AddItem i, i - 1
Next
Case 5

For i = 1 To 31
Combo3.AddItem i, i - 1
Next
Case 6

For i = 1 To 30
Combo3.AddItem i, i - 1
Next
Case 7

For i = 1 To 31
Combo3.AddItem i, i - 1
Next
Case 8

For i = 1 To 31
Combo3.AddItem i, i - 1
Next
Case 9

For i = 1 To 30
Combo3.AddItem i, i - 1
Next
Case 10

For i = 1 To 31
Combo3.AddItem i, i - 1
Next
Case 11

For i = 1 To 30
Combo3.AddItem i, i - 1
Next
Case 12

For i = 1 To 31
Combo3.AddItem i, i - 1
Next
End Select
Combo3.Text = com11
Dim ty As Integer, tm As Integer, td As Integer, yl As String, sx As String, yOn As Boolean
yOn = False
If Check1.Value = 1 Then
yOn = True
End If
lb.Caption = FunGetDate(CInt(Combo1.Text), CInt(Combo2.Text), CInt(com11), yl, sx, yOn) & " " & yl & " " & sx


End Sub

Private Sub Combo3_Click()
Dim ty As Integer, tm As Integer, td As Integer, yl As String, sx As String, yOn As Boolean
yOn = False
If Check1.Value = 1 Then
yOn = True
End If
lb.Caption = FunGetDate(CInt(Combo1.Text), CInt(Combo2.Text), CInt(Combo3.Text), yl, sx, yOn) & " " & yl & " " & sx



End Sub

Private Sub Form_Load()
For i = 1900 To 2011
Combo1.AddItem i, i - 1900
Next
For i = 1 To 12
Combo2.AddItem i, i - 1
Next
Select Case Combo2.Text
Case 1

For i = 1 To 31
Combo3.AddItem i, i - 1
Next
Case 2
If Combo1.Text Mod 4 <> 0 Then
For i = 1 To 28
Combo3.AddItem i, i - 1
Next
Else
For i = 1 To 29
Combo3.AddItem i, i - 1
Next
End If
Case 3
For i = 1 To 31
Combo3.AddItem i, i - 1
Next
Case 4

For i = 1 To 30
Combo3.AddItem i, i - 1
Next
Case 5

For i = 1 To 31
Combo3.AddItem i, i - 1
Next
Case 6

For i = 1 To 30
Combo3.AddItem i, i - 1
Next
Case 7

For i = 1 To 31
Combo3.AddItem i, i - 1
Next
Case 8

For i = 1 To 31
Combo3.AddItem i, i - 1
Next
Case 9

For i = 1 To 30
Combo3.AddItem i, i - 1
Next
Case 10

For i = 1 To 31
Combo3.AddItem i, i - 1
Next
Case 11

For i = 1 To 30
Combo3.AddItem i, i - 1
Next
Case 12

For i = 1 To 31
Combo3.AddItem i, i - 1
Next
End Select
Combo1.Text = Year(Now)
Combo2.Text = Month(Now)
Combo3.Text = Day(Now)

End Sub

[DengXingJie]

呵呵
楼上兄弟不错

[xiediy7]

我也拿来修改一下，给论坛修饰一下．

[wukum]

疯跑君的代码得补充一个check控件，属性取默认即可，
可是似乎只是阴历转阳历，结果在lb控件上显示。
如果要阳历转阴历呢？
这个代码的注解太少了，能否请哪个大侠代为添上重要注解？万分感谢。

[wukum]

明白了，那个check就是用来控制阴转阳与阳转阴的，yl一定要声明为string，返回的是十二天干地支，sx是返回生肖，也必须声明为string，
如果不加入何控件，想在程序的任意位置调用，则如下做：
比如用一个按钮得到当前日期的阴历时间：
Private Sub Command1_Click()
Dim ty As Integer, tm As Integer, td As Integer, yl As String, sx As String, yOn As Boolean
yOn = False
yy=date()
xx = FunGetDate(CInt(Year(yy)), CInt(Month(yy)), CInt(Day(yy)), yl, sx, yOn) & " " & yl & " " & sx
MsgBox xx, vbOKOnly, "今天阴历为："
End Sub
当然，如果须要把阴历转为阳历，则把上面的yOn值设为True即可。上面的yy也可替换成text控件内的日期字符串。

我的备忘录，嘿嘿。
别人的硬盘才是安全的。

[zhouweizhu]

那楼兄弟贴的不错，支持下

[wyf2]

好贴，学了

[loveisbug]

曾在机顶盒上做过，带宜忌。

[可西哥]

mark

[aswq1314]

曾在机顶盒上做过，带宜忌。
强啊~~~~~~~~~~

[loveisbug]

没办法，客户需要，看黄历，主要是看这个。