<br data-filtered=
"filtered"
>
'公历转农历模块
'原创:互联网
'修正:
'// 农历数据定义 //
'先以 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
联系客服