公历转农历模块

公历转农历模块

'// 农历数据定义//

'先以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,4 AE00D2," _

&

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

&

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

&

"D4A00D9,EA500CE,6A9157E,5AD00D6,2B600CC,86E137C,92E00D3,C8D1783,C9500DB,D 4A00D0," _

&

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

&

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

&

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

&

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

&

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

AF057F," _

&

"49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00D8,C96 00CD," _

&

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

&

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

&

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

&

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

&

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

&

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

&

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

&

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

&

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

&

"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