公历、农历互相转换函数 公历和农历转换

'公历、农历互相转换模块

'原创:互联网

'修正:阿勇 2005/1/12

'// 农历数据定义 //

'先以 H2B 函数还原成长度为 18 的字符串,其定义如下:

'前12个字节代表1-12月:1为大月,0为小月;压缩成十六进制(1-3位)

'第13位为闰月的情况,1为大月30天,0为小月29天;(4位)

'第14位为闰月的月份,如果不是闰月为0,否则给出月份(5位)

'最后4位为当年农历新年的公历日期,如0131代表1月31日;当作数值转十六进制(6-7位)

'农历常量(1899~2100,共202年)

Private Const ylData = "AB500D2,4BD0883," _

& "4AE00DB,A5700D0,54D0581,D2600D8,D9500CC,655147D,56A00D5,9AD00CA,55D027A,4AE00D2," _

& "A5B0682,A4D00DA,D2500CE,D25157E,B5500D6,56A00CC,ADA027B,95B00D3,49717C9,49B00DC," _

& "A4B00D0,B4B0580,6A500D8,6D400CD,AB5147C,2B600D5,95700CA,52F027B,49700D2,6560682," _

& "D4A00D9,EA500CE,6A9157E,5AD00D6,2B600CC,86E137C,92E00D3,C8D1783,C9500DB,D4A00D0," _

& "D8A167F,B5500D7,56A00CD,A5B147D,25D00D5,92D00CA,D2B027A,A9500D2,B550781,6CA00D9," _

& "B5500CE,535157F,4DA00D6,A5B00CB,457037C,52B00D4,A9A0883,E9500DA,6AA00D0,AEA0680," _

& "AB500D7,4B600CD,AAE047D,A5700D5,52600CA,F260379,D9500D1,5B50782,56A00D9,96D00CE," _

& "4DD057F,4AD00D7,A4D00CB,D4D047B,D2500D3,D550883,B5400DA,B6A00CF,95A1680,95B00D8," _

& "49B00CD,A97047D,A4B00D5,B270ACA,6A500DC,6D400D1,AF40681,AB600D9,93700CE,4AF057F," _

& "49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00D8,C9600CD," _

& "D95047C,D4A00D4,DA500C9,755027A,56A00D1,ABB0781,25D00DA,92D00CF,CAB057E,A9500D6," _

& "B4A00CB,BAA047B,B5500D2,55D0983,4BA00DB,A5B00D0,5171680,52B00D8,A9300CD,795047D," _

& "6AA00D4,AD500C9,5B5027A,4B600D2,96E0681,A4E00D9,D2600CE,EA6057E,D5300D5,5AA00CB," _

& "76A037B,96D00D3,4AB0B83,4AD00DB,A4D00D0,D0B1680,D2500D7,D5200CC,DD4057C,B5A00D4," _

& "56D00C9,55B027A,49B00D2,A570782,A4B00D9,AA500CE,B25157E,6D200D6,ADA00CA,4B6137B," _

& "93700D3,49F08C9,49700DB,64B00D0,68A1680,EA500D7,6AA00CC,A6C147C,AAE00D4,92E00CA," _

& "D2E0379,C9600D1,D550781,D4A00D9,DA400CD,5D5057E,56A00D6,A6C00CB,55D047B,52D00D3," _

& "A9B0883,A9500DB,B4A00CF,B6A067F,AD500D7,55A00CD,ABA047C,A5A00D4,52B00CA,B27037A," _

& "69300D1,7330781,6AA00D9,AD500CE,4B5157E,4B600D6,A5700CB,54E047C,D1600D2,E960882," _

& "D5200DA,DAA00CF,6AA167F,56D00D7,4AE00CD,A9D047D,A2D00D4,D1500C9,F250279,D5200D1"

Private Const ylMd0 = "初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五" _

& "十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十 "

Private Const ylMn0 = "正二三四五六七八九十冬腊"

Private Const ylTianGan0 = "甲乙丙丁戊已庚辛壬癸"
公历、农历互相转换函数 公历和农历转换

Private Const ylDiZhi0 = "子丑寅卯辰巳午未申酉戌亥"

Private Const ylShu0 = "鼠牛虎兔龙蛇马羊猴鸡狗猪"

'公历日期转农历

Function GetYLDate(ByVal strDate As String) As String

On Error GoTo aErr

If Not IsDate(strDate) Then Exit Function

Dim setDate As Date, tYear As Integer, tMonth As Integer, tDay As Integer

setDate = CDate(strDate)

tYear = Year(setDate): tMonth = Month(setDate): tDay = Day(setDate)

'如果不是有效有日期,退出

If tYear > 2100 Or tYear < 1900 Then Exit Function

Dim daList() As String * 18, conDate As Date, thisMonths As String

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

Dim YLyear As String, YLShuXing As String

Dim dd0 As String, mm0 As String, ganzhi(0 To 59) As String * 2

Dim RunYue As Boolean, RunYue1 As Integer, mDays As Integer, i As Integer

'加载2年内的农历数据

ReDim daList(tYear - 1 To tYear)

daList(tYear - 1) = H2B(Mid(ylData, (tYear - 1900) * 8 + 1, 7))

daList(tYear) = H2B(Mid(ylData, (tYear - 1900 + 1) * 8 + 1, 7))

AddYear = tYear

initYL:

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

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

conDate = DateSerial(AddYear, AddMonth, AddDay) '农历新年日期

getDay = DateDiff("d", conDate, setDate) + 1'相差天数

If getDay < 1 Then AddYear = AddYear - 1: GoTo initYL

thisMonths = Left(daList(AddYear), 14)

RunYue1 = Val("&H" & Right(thisMonths, 1)) '闰月月份

If RunYue1 > 0 Then'有闰月

thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)

End If

thisMonths = Left(thisMonths, 13)

For i = 1 To 13'计算天数

mDays = 29 + CInt(Mid(thisMonths, i, 1))

If getDay > mDays Then

getDay = getDay - mDays

Else

If RunYue1 > 0 Then

If i = RunYue1 + 1 Then RunYue = True

If i > RunYue1 Then i = i - 1

End If

AddMonth = i

AddDay = getDay

Exit For

End If

Next

dd0 = Mid(ylMd0, (AddDay - 1) * 2 + 1, 2)

mm0 = Mid(ylMn0, AddMonth, 1) + "月"

For i = 0 To 59

ganzhi(i) = Mid(ylTianGan0, (i Mod 10) + 1, 1) + Mid(ylDiZhi0, (i Mod 12) + 1, 1)

Next i

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

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

If RunYue Then mm0 = "闰" & mm0

GetYLDate = "农历" & YLyear & "(" & YLShuXing & ")年" & mm0 & dd0

aErr:

End Function

'农历转公历日期

'若 secondMonth 为真,则当 tMonth 是闰月时,取第二个月

Function GetDate(ByVal tYear As Integer, tMonth As Integer, tDay As Integer, Optional secondMonth As Boolean = False) As String

On Error GoTo aErr

If tYear > 2100 Or tYear < 1899 Or tMonth > 12 Or tMonth < 1 Or tDay > 30 Or tDay < 1 Then Exit Function

Dim thisMonths As String, ylNewYear As Date, toMonth As Integer

Dim mDays As Integer, RunYue1 As Integer, i As Integer

thisMonths = H2B(Mid(ylData, (tYear - 1899) * 8 + 1, 7))

If tDay > 29 + CInt(Mid(thisMonths, tMonth, 1)) Then Exit Function

ylNewYear = DateSerial(tYear, CInt(Mid(thisMonths, 15, 2)), CInt(Mid(thisMonths, 17, 2))) '农历新年日期

thisMonths = Left(thisMonths, 14)

RunYue1 = Val("&H" & Right(thisMonths, 1)) '闰月月份

toMonth = tMonth - 1

If RunYue1 > 0 Then'有闰月

thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)

If tMonth > RunYue1 Or (secondMonth And tMonth = RunYue1) Then toMonth = tMonth

End If

thisMonths = Left(thisMonths, 13)

mDays = 0

For i = 1 To toMonth

mDays = mDays + 29 + CInt(Mid(thisMonths, i, 1))

Next

mDays = mDays + tDay

GetDate = ylNewYear + mDays - 1

aErr:

End Function

'将压缩的阴历字符还原

Private Function H2B(ByVal strHex As String) As String

Dim i As Integer, i1 As Integer, tmpV As String

Const hStr = "0123456789ABCDEF"

Const bStr = "0000000100100011010001010110011110001001101010111100110111101111"

tmpV = UCase(Left(strHex, 3))

'十六进制转二进制

For i = 1 To Len(tmpV)

i1 = InStr(hStr, Mid(tmpV, i, 1))

H2B = H2B & Mid(bStr, (i1 - 1) * 4 + 1, 4)

Next

H2B = H2B & Mid(strHex, 4, 2)

'十六进制转十进制

H2B = H2B & "0" & CStr(Val("&H" & Right(strHex, 2)))

End Function

公历转农历示例:

=GetYLDate("2009-5-24") 返回2009年5月24日的农历日期:农历已丑(牛)年五月初一

=GetYLDate("2009-6-23") 返回2009年6月23日的农历日期:农历已丑(牛)年闰五月初一

农历转公历示例:

=GetDate(2009,5,1) 返回2009年五月初一的公历日期:2009-5-24

=GetDate(2009,5,1,1) 返回2009年闰五月初一的公历日期:2009-6-23

  

爱华网本文地址 » http://www.413yy.cn/a/25101014/189739.html

更多阅读

二进制数与十六进制数之间如何互相转换 二进制转换十六进制

二进制数与十六进制数之间如何互相转换——简介二进制与十六进制之间的转换与二进制和八进制之间的转换很类似,今天我们来详细看一下:首先,我们来看一下数学关系即24=16,即用四位二进制表示一位八进制。二进制数与十六进制数之间如何互

1、4《噪声的危害和控制》导学案 噪声的危害和控制

【学习目标】1、知识与技能了解噪声的来源和危害;知道防治噪声的途径,增强环境保护的意识;2、过程与方法通过体验和观察,了解防治噪声的思路,培养学生应用物理知识解决实际问题的能力;3、情感态度与价值观通过学习,培养热爱、保护我们赖以

声明:《公历、农历互相转换函数 公历和农历转换》为网友狂暴的酷分享!如侵犯到您的合法权益请联系我们删除