VB中如何进行公历到农历的转换

ikey 2003-02-08 04:49:15
VB中如何进行公历到农历的转换，比如农历1976-02-13 对应 公历为1976-03-13，请指导
...全文
297 7 打赏 收藏 转发到动态 举报
写回复
用AI写文章
7 条回复
切换为时间正序
请发表友善的回复…
发表回复
ricemaster 2003-02-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
雨谦飞扬 2003-02-08
  • 打赏
  • 举报
 回复
学习jennyvenus的帖子中...
since1990 2003-02-08
  • 打赏
  • 举报
 回复
up
龙华 2003-02-08
  • 打赏
  • 举报
 回复
看看这里，5分钟搞定。
http://www.netspider.8u8.net/prgmexmps/pe0103.htm
用户　昵称 2003-02-08
  • 打赏
  • 举报
 回复
Top

回复人： w18ily(再回首，西门吹沙) ( ) 信誉：105 2002-11-26 21:38:00 得分:0


（算法三）

'根据给定的阳历，返回农历的日期

Function GetLunar(ByVal SolarDate As Date) As String

Dim DaysOffset As Long

Dim i As Integer

Dim Temp As Long

Dim lyear, lmonth, lday As Integer

DaysOffset = SolarDate - CDate("1900-1-31")

i = 1900

Do While i < 2050 And DaysOffset >= 0

Temp = lYearDays(i)

DaysOffset = DaysOffset - Temp

i = i + 1

Loop

If DaysOffset < 0 Then

DaysOffset = DaysOffset + Temp

i = i - 1

End If

lyear = i

Dim Leap As Integer

Dim IsLeap As Boolean

Leap = LeapMonth(i)

IsLeap = False

i = 1

Do While i < 13 And DaysOffset > 0

If Leap > 0 And i = (Leap + 1) And IsLeap = False Then

i = i - 1

IsLeap = True

Temp = LeapDays(lyear)

Else

Temp = lMonthDays(lyear, i)

End If

If IsLeap And i = (Leap + 1) Then IsLeap = False

DaysOffset = DaysOffset - Temp

i = i + 1

Loop

If DaysOffset = 0 And Leap > 0 And i = Leap + 1 Then

If IsLeap Then

IsLeap = False

Else

IsLeap = True

i = i - 1

End If

End If

If DaysOffset < 0 Then

DaysOffset = DaysOffset + Temp

i = i - 1

End If

lmonth = i

lday = DaysOffset + 1


'返回特殊标志的字符串

If IsLeap Then

'GetLunar = "0000【" & Animal(lYear) & "】" & GanZhi(lYear) & "年闰" & Format(lMonth, "00") & "月" & Format(lDay, "00") & "日" & GetTerm(SolarDate)

GetLunar = "1" & lyear & Format(lmonth, "00") & Format(lday, "00")

Else

GetLunar = "0" & lyear & Format(lmonth, "00") & Format(lday, "00")

'GetLunar = Format(lMonth, "00") & Format(lDay, "00") & "【" & Animal(lYear) & "】" & GanZhi(lYear) & "年" & Format(lMonth, "00") & "月" & Format(lDay, "00") & "日 " & GetTerm(SolarDate)

End If

End Function

　

'某y年的第n个节气的日期(从1小寒起算)

Function sTerm(ByVal Y, n As Integer) As Date

Dim D1, D2 As Double

D1 = (31556925.9747 * (Y - 1900) + sTermInfo(n) * 60#)

D2 = DateDiff("s", "1970-1-1 0:0", "1900-1-6 2:5") + D1

D1 = D2 / 2

sTerm = DateAdd("s", D2 - D1, DateAdd("s", D1, "1970-1-1 0:0"))

sTerm = Format(sTerm, "yyyy/mm/dd")

End Function

　

'根据阳历返回其节气，若不是则返回空

Function GetTerm(ByVal sDate As Date) As String

Dim Y, m As Integer

Y = Year(sDate)

m = Month(sDate)

GetTerm = " "

If sTerm(Y, m * 2 - 1) = sDate Then

GetTerm = SolarTerm(m * 2 - 1)

ElseIf sTerm(Y, m * 2) = sDate Then

GetTerm = SolarTerm(m * 2)

End If

End Function

　

'返回阳历是该月的第几个星期几的字符串，如:0520表示5月份第2个星期日

Function GetMonthWeek(ByVal sDate As Date) As String

Dim D0 As Date

D0 = CDate(Year(sDate) & "-" & Month(sDate) & "-1")

GetMonthWeek = Format(Month(sDate), "00") & (Int((Day(sDate) - 1 + Weekday(D0) - 1) / 7) + 1) & Weekday(sDate) - 1

End Function
用户　昵称 2003-02-08
  • 打赏
  • 举报
 回复
阴阳历转换的源码和相关的介绍
1)
http://www.lhren.com/bbs/dispbbs.asp?BoardID=4&ID=112&replyID=208&skin=1
2)
这里有一个控件http://www.csdn.net/cnshare/soft/7/7386.shtm
3)
http://www.chinaithero.com/dev/vccool/sys_time.htm
4)
(算法一)

‘*********************************

‘定义变量

‘*********************************

Public LunarInfo(1 To 150) As Double '从1900-2049年这150年的农历信息码

Public SolarMonth(1 To 12) As Integer '阳历12个月的天数

Public Gan(1 To 10) As String '农历的天干

Public Zhi(1 To 12) As String '农历的地支

Public Animals(1 To 12) As String '农历的属象

Public SolarTerm(1 To 24) As String '阳历的节气

　

Public sTermInfo(1 To 24) As Double '阳历节气的信息码

Public nStr1(1 To 11) As String '从日一到十

Public nStr2(1 To 5) As String '初十廿卅　'

　

Public MonthName(1 To 12) As String '每个月的英文名称

　

Public sFtv(1 To 30) As String '阳历的节日

Public lFtv(1 To 30) As String '农历的节日

Public wFtv(1 To 30) As String '西方的节日

　

　

‘*********************

‘赋值：略

‘*********************

LunarInfo（1 to 150）：

0x04bd8,0x04ae0,0x0a570,0x054d5,0x0d260,0x0d950,0x16554,0x056a0,0x09ad0,0x055d2,

0x04ae0,0x0a5b6,0x0a4d0,0x0d250,0x1d255,0x0b540,0x0d6a0,0x0ada2,0x095b0,0x14977,

0x04970,0x0a4b0,0x0b4b5,0x06a50,0x06d40,0x1ab54,0x02b60,0x09570,0x052f2,0x04970,

0x06566,0x0d4a0,0x0ea50,0x06e95,0x05ad0,0x02b60,0x186e3,0x092e0,0x1c8d7,0x0c950,

0x0d4a0,0x1d8a6,0x0b550,0x056a0,0x1a5b4,0x025d0,0x092d0,0x0d2b2,0x0a950,0x0b557,

0x06ca0,0x0b550,0x15355,0x04da0,0x0a5d0,0x14573,0x052d0,0x0a9a8,0x0e950,0x06aa0,

0x0aea6,0x0ab50,0x04b60,0x0aae4,0x0a570,0x05260,0x0f263,0x0d950,0x05b57,0x056a0,

0x096d0,0x04dd5,0x04ad0,0x0a4d0,0x0d4d4,0x0d250,0x0d558,0x0b540,0x0b5a0,0x195a6,

0x095b0,0x049b0,0x0a974,0x0a4b0,0x0b27a,0x06a50,0x06d40,0x0af46,0x0ab60,0x09570,

0x04af5,0x04970,0x064b0,0x074a3,0x0ea50,0x06b58,0x055c0,0x0ab60,0x096d5,0x092e0,

0x0c960,0x0d954,0x0d4a0,0x0da50,0x07552,0x056a0,0x0abb7,0x025d0,0x092d0,0x0cab5,

0x0a950,0x0b4a0,0x0baa4,0x0ad50,0x055d9,0x04ba0,0x0a5b0,0x15176,0x052b0,0x0a930,

0x07954,0x06aa0,0x0ad50,0x05b52,0x04b60,0x0a6e6,0x0a4e0,0x0d260,0x0ea65,0x0d530,

0x05aa0,0x076a3,0x096d0,0x04bd7,0x04ad0,0x0a4d0,0x1d0b6,0x0d250,0x0d520,0x0dd45,

0x0b5a0,0x056d0,0x055b2,0x049b0,0x0a577,0x0a4b0,0x0aa50,0x1b255,0x06d20,0x0ada0

　

For i = 1 To 12

Select Case i

Case 1, 3, 5, 7, 8, 10, 12

SolarMonth(i) = 31

Case 2

SolarMonth(i) = 28

Case Else

SolarMonth(i) = 30

End Select

Next i


Dim s1, s2, s3, s4, s5, s6, s7, s8 As String

s1 = "甲乙丙丁戊己庚辛壬癸"

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

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

s4 = "小寒大寒立春雨水惊蛰春分清明谷雨立夏小满芒种夏至小暑大暑立秋处暑白露秋分寒露霜降立冬小雪大雪冬至"

s5 = "000000,021208,042467,063836,085337,107014,128867,150921,173149,195551,218072,240693,263343,285989,308563,331033,353350,375494,397447,419210,440795,462224,483532,504758"

s6 = "日一二三四五六七八九十"

s7 = "初十廿卅　"

s8 = "JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC"

For i = 1 To 24

If i <= 10 Then Gan(i) = Mid(s1, i, 1)

If i <= 12 Then

Zhi(i) = Mid(s2, i, 1)

Animals(i) = Mid(s3, i, 1)

End If

（算法二）

SolarTerm(i) = Mid(s4, (i - 1) * 2 + 1, 2)

sTermInfo(i) = Val(Mid(s5, (i - 1) * 7 + 1, 6))

If i <= 11 Then nStr1(i) = Mid(s6, i, 1)

If i <= 5 Then nStr2(i) = Mid(s7, i, 1)

If i <= 12 Then MonthName(i) = Mid(s8, (i - 1) * 4 + 1, 3)

Next i


‘阳历节日：前四位数字为阳历的MMDD（月日），后面的文字为意义

sFtv(1) = "0101*元旦"

sFtv(2) = "0214情人节"

sFtv(3) = "0308妇女节"

sFtv(4) = "0312植树节"

sFtv(5) = "0315权益日"

sFtv(6) = ""

sFtv(7) = "0401愚人节"

sFtv(8) = "0501*劳动节"

sFtv(9) = "0504青年节"

sFtv(10) = "0512护士节"

sFtv(11) = "0601儿童节"

sFtv(12) = "0701建党节"

sFtv(13) = "0718托普诞辰"

sFtv(14) = "0801建军节"

sFtv(15) = "0808父亲节"

sFtv(16) = "0909毛逝世纪念"

sFtv(17) = "0910教师节"

sFtv(18) = "0928孔子诞辰"

sFtv(19) = "1001*国庆节"

sFtv(20) = "1006老人节"

sFtv(21) = "1024联合国日"

sFtv(22) = "1112孙中山诞辰"

sFtv(23) = "1220澳门回归"

sFtv(24) = "1225圣诞节"

sFtv(25) = "1226毛诞辰纪念"


‘农历的节日：日期表示的是农历的某月某日

lFtv(1) = "0101*春节"

lFtv(2) = "0115元宵节"

lFtv(3) = "0505端午节"

lFtv(4) = "0707七夕节"

lFtv(5) = "0715中元节"

lFtv(6) = "0815中秋节"

lFtv(7) = "0909重阳节"

lFtv(8) = ""

lFtv(9) = "1208腊八节"

lFtv(10) = "1224小年"

lFtv(11) = "0100*除夕"


‘按星期计算的节日：如0231表示阳历02月份的第三个星期一

wFtv(1) = ""

wFtv(2) = "0231总统日"

wFtv(3) = "0520母亲节"

wFtv(4) = ""

wFtv(5) = "0531胜利日"

wFtv(6) = "0716合作节"

wFtv(7) = "0730被奴周"

wFtv(8) = ""

wFtv(9) = ""

wFtv(10) = "1021哥伦布日"

wFtv(11) = "1144感恩节"


‘**************************************

‘日历系统中的常用处理函数

‘**************************************

'传回农历 y年m月的总天数

Function lMonthDays(ByVal Y As Integer, ByVal m As Integer) As Integer

If Y < 1900 Then Y = 1900

If (LunarInfo(Y - 1900 + 1) And Int(&H10000 / (2 ^ m))) = 0 Then

lMonthDays = 29

Else

lMonthDays = 30

End If

End Function

　

'传回农历 y年闰哪个月 1-12 , 没闰传回 0

Function LeapMonth(ByVal Y As Integer) As Integer

LeapMonth = 0

If Y >= 1900 Then LeapMonth = (LunarInfo(Y - 1900 + 1) And &HF)

End Function

　

　

'传回农历 y年闰月的天数

Function LeapDays(ByVal Y As Integer) As Integer

Dim m As Integer

Dim l As Double

m = LeapMonth(Y)

If m = 0 Then

LeapDays = 0

Else

l = LunarInfo(Y - 1900 + 1)

If l < 0 Then l = l * (-1)

l = (l And &H10000)

If l = 0 Then

LeapDays = 29

Else

LeapDays = 30

End If

End If

End Function

　

'传回农历 y年的总天数

Function lYearDays(ByVal Y As Integer) As Integer

Dim i, Sum As Double

Sum = 0

For i = 1 To 12

Sum = Sum + lMonthDays(Y, i)

Next i

lYearDays = Sum + LeapDays(Y)

End Function

　

'传回阳历 y年某m月的天数

Function SolarDays(ByVal Y As Integer, ByVal m As Integer) As Integer

If m = 2 Then

If (Y Mod 4 = 0 And Y Mod 100 <> 0) Or (Y Mod 400 = 0) Then

SolarDays = 29

Else

SolarDays = 28

End If

Else

SolarDays = SolarMonth(m)

End If

End Function

　

'根据年份返回属象

Function Animal(ByVal sYear As Integer) As String

Animal = Animals((sYear - 1900) Mod 12 + 1)

End Function


northwolves 2003-02-08
  • 打赏
  • 举报
 回复
下载农历控件。
vb公历农历转换.rarvb公历农历转换.rar
vb公历农历转换.rarvb公历农历转换.rarvb公历农历转换.rarvb公历农历转换.rar
vb公历农历转换
用vb编写的公历农历转换工具
vb公历农历转换.rar
vb公历农历转换.rar 毕业程序设计~~
vb公历农历转换源码及文档说明
vb公历农历转换源码及文档说明，学习VB的一个示例，希望有帮助
VB农历转换,自编阳历与农历转换程序
摘要:VB源码,其它类别,日历转换,农历转换 农历转换,自编简单阳历与农历转换小程序，公历与农历之间的日期转换，有节日。菜鸟练手请多多包涵。使用方法，在窗口中先把需要转换的日期即可，选择后会自动在窗口下方显示农历和属相信息，比较简单。 运行环境：Windows/VB6
VB基础类

7,763

社区成员

197,609

社区内容

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今

加载中

查看更多榜单
社区公告
暂无公告

试试用AI创作助手写篇文章吧

+ 用AI写文章