1900-2100公历年以查表方式取农历二十四节气(VBA)
在前两天，发了一段农历转公历的代码，今天再把获取二十四节气的代码给完成了。
同样，基础数据及参照代码来自：http://s.o4u.com/host/blog/calendar/calendar.htm
前提：
农历二十节气，以地球绕太阳公转轨迹，以15度均匀分割，在1900~2100这个时间段，有以下规律：
1.每公历月份，都有两个节气，分别在月首及月尾
2.每个节气在月内与基准日期相差的天数为0-3天
3.在1900~2100这201年，节气的分布种类共有69种
以上是由数据总结出来的，可以由此生成编程所需的数据，如下：（注：本数据由来源地址的代码中转换而来）
' 二十四节气在各月的基准日期
solarTermBase = Array(4, 19, 3, 18, 4, 19, 4, 19, 4, 20, 4, 20, 6, 22, 6, 22, 6, 22, 7, 22, 6, 21, 6, 21)
' 二十四节气以年为单位，在1900-2100年间，共有69种分布种类，一个长整型存储12个节气与基准日的天数差额，共2*69项(每2bit表示一个节气的天数差，0-3天，高8位置0)
solarTermOS = Array( _
&H95A59A, &H599AA5, &HA5A6AA, &H9AAAA9, &HA9AAAE, &HAAAAAA, &HAAFAEE, &HAEEAAA, &HEAA59A, &H599AA5, &HA9AAAA, &HAAAAAA, &HEAA59A, &H599A95, &H95A6AA, &H9A9AA9, _
&HA5A6AA, &HAAAAAA, &HAABAAE, &HAAEAAA, &HAAA59A, &H599695, &H95A69A, &H9A9AA9, &HA5A6AA, &HAAAAA9, &H95A59A, &H9A9AA5, &HA9AAAE, &HAAEAAA, &HAAA59A, &H599555, _
&HAAA599, &H599555, &HAAA559, &H599555, &H95A59A, &H599695, &HAA6559, &H559555, &H55A59A, &H599695, &H95A59A, &H9A9AA9, &HAA5559, &H559555, &HA95559, &H555555, _
&H55A599, &H599555, &HA95555, &H555555, &H55A559, &H599555, &HA5A6AA, &H9A9AA9, &HA95155, &H555555, &H55A559, &H559555, &H95A59A, &H5996A5, &HA55155, &H455555, _
&H556559, &H559555, &H95A59A, &H5A9AA5, &HA55155, &H455554, &H555559, &H555555, &H55A599, &H599695, &H545559, &H555555, &H545555, &H595555, &H545555, &H555555, _
&HA55155, &H454554, &H545155, &H555555, &HA55145, &H454554, &H545155, &H455555, &H955045, &H454554, &H505155, &H455555, &H955045, &H44554, &H505155, &H455554, _
&H955045, &H44550, &H505145, &H454554, &H955045, &H44150, &H505045, &H454554, &H955044, &H44140, &H405045, &H44554, &H555044, &H44140, &H555555, &H555555, _
&H405045, &H44550, &H555044, &H44000, &H555004, &H4000&, &H405045, &H44150, &H505045, &H54554, &H405044, &H44140, &H505045, &H44554, &H550004, &H0&, _
&H5044&, &H44140, &H550000, &H0&, &H5044&, &H44000, &H540000, &H0&, &H5044&, &H4000&)
' 1900-2100各年的二十四节气分布种类，对应上表中的序号，一个长整型保存4年序号，每8bit一个序号（序号=0-68)
solarTermIdx = Array( _
&H10203, &H4010503, &H4010503, &H6070809, &HA0B0C09, &HA0D0C0E, &HA0D010E, &HF000102, &H10000105, &H10000105, _
&H10000105, &H11120708, &H13141508, &H13140D01, &H16140001, &H17180001, &H17180001, &H19180001, &H191A001B, &H1C1D1E0B, _
&H1C1D1215, &H1F201421, &H22232400, &H22251800, &H22261800, &H22271800, &H22271D00, &H28291D1E, &H2A2B1D12, &H2C2D2024, _
&H2E2F2324, &H302F2718, &H302F2718, &H302F271D, &H302F271D, &H3031291D, &H32332B1D, &H34352D23, &H36352D37, &H36382F37, _
&H39382F27, &H39382F27, &H3A383127, &H3A3B312B, &H3A3B3C2B, &H3A3D3E2D, &H3F40352D, &H4140382F, &H4142382F, &H4344382F, _
&H27000000)有了数据后，编码是非常简单的，只要由年份确定该年的二十节气分布种类，是69种里面的哪一种（查表方式），取出分布种类的定义信息后，再取某节气的偏差天数。最终返回 基准天数 + 偏差天数 即可。
代码比较简单，不再作详解（在参考代码里，用JS实现的代码，本函数只有一句代码）
附示例代码（在上次的代码基础上，加了公历转农历的方法，但请注意，目前尚未处理公历1900/1/1~农历1900/1/1之间的数据，因为参考代码中，信息表中未包含这段信息）：
农历日期数据类型定义：
Option Explicit
Type LunarDate
year As Long '农历年份(西历纪年1900-2100)
month As Integer '农历月份(1-12)
day As Integer '农历日期(1-30)
isLeap As Boolean '是否为闰月年(True=有闰月 Flas=无闰月)
solarIndex As Integer '二十四节气(0-24) 0=当日没有节气
End Type'
'根据农历年月日取对应公历日期 类模块
' (By 漠石 [email protected])
'
' 本类只有一个公用方法：
' Public Function GetDateFromLunar(y As Long, m As Long, d As Long, Optional isLeap As Boolean = False) As Date
' y: 1900 - 2100 200年
' m: 1 - 12 月份
' d: 1 - 30，如果是小月，并且传入了30，则返回下一农历月第一天的公历
' isLeap: 是否为闰月
'
'==========================================================================================
' 注：本模块的数据及代码参照自：http://s.o4u.com/host/blog/calendar/calendar.htm
' 以下为原作者信息：
' ***************************************
' 農曆月曆&世界時間 DHTML 程式 (台灣版)
' ***************************************
' 最後修改: 2009 年 3 月 20 日
'
'
'如果您覺得這個程式不錯，您可以自由轉寄給親朋好友分享。自由使
'用範圍: 學校、學會、公會、公司內部、程式研究、個人網站供人查
'詢使用?
'
'Open Source 不代表放棄著作權，任何形式之引用或轉載前請來信告
'知。如需於「商業或營利」目的中使用此部份之程式碼或資料，需取
'得本人書面授權。
'
'最新版本與更新資訊於 http://sean.o4u.com/ap/calendar/ 公佈
'
'
' 歡迎來信互相討論研究與指正誤謬
' 連絡方式：http://sean.o4u.com/contact/
' Sean Lin(林洵賢)
' 尊重他人創作?請勿刪除或變更此說明
Option Explicit
Private compressLunarInfo As Variant
Private solarTermBase As Variant, solarTermOS As Variant, solarTermIdx As Variant
Private dateOfLunarYearBegin() As Date
Private Const LUNAR_YEAR_START As Long = 1900
Private Const LUNAR_YEAR_END As Long = 2100
Private Const FL_M As Integer = 1
Private Const FL_D As Integer = 31
'#### 根据农历年月日返回公历日期
Public Function GetGregorian(ByVal y As Long, ByVal m As Long, ByVal d As Long, Optional ByVal isLeap As Boolean = False) As Date
Dim sum As Long, leapMonth As Integer
If y < LUNAR_YEAR_START Or y > LUNAR_YEAR_END Then
Err.Raise Number:=6, DESCRIPTION:="只接受 " & LUNAR_YEAR_START & " - " & LUNAR_YEAR_END & " 之间的年份"
Exit Function
End If
If m < 1 Or m > 12 Then
Err.Raise Number:=7, DESCRIPTION:="只接受 1 - 12 之间的月份"
Exit Function
End If
If d < 1 Or d > 30 Then
Err.Raise Number:=8, DESCRIPTION:="只接受 1 - 30 之间的日期"
Exit Function
End If
If Not isLeap Then
sum = GetMultiLunarMonthDays(y, m - 1) + d - 1
Else
leapMonth = GetLeapMonth(y)
If leapMonth <> m Then
Err.Raise Number:=9, DESCRIPTION:="不是闰月"
Exit Function
End If
sum = GetMultiLunarMonthDays(y, m) + d - 1
End If
' 年初日期 + 偏移天数
GetGregorian = DateAdd("d", sum, dateOfLunarYearBegin(y - LUNAR_YEAR_START))
End Function
'#### 返回 y 年第 n 个节气的日期（4-25） y=1900-2100, n=1-24
Public Function GetSolarTerm(ByVal y As Long, ByVal n As Integer) As Integer
Dim i As Integer, idxIndex As Integer, idxOffset As Integer, mask As Long, OSIndex As Long, OSValue As Long, OSOffset As Integer
If y < LUNAR_YEAR_START Or y > LUNAR_YEAR_END Then
Err.Raise Number:=6, DESCRIPTION:="只接受 " & LUNAR_YEAR_START & " - " & LUNAR_YEAR_END & " 之间的年份"
Exit Function
End If
If n < 1 Or n > 24 Then
Err.Raise Number:=10, DESCRIPTION:="只接受 1 - 24 之间的节气序号"
Exit Function
End If
idxIndex = (y - LUNAR_YEAR_START) \ 4
idxOffset = (y - LUNAR_YEAR_START) Mod 4
mask = &H7F&
' 每 step 向左移 8 位
For i = 1 To 3 - idxOffset
mask = mask * &H100
Next i
OSIndex = solarTermIdx(idxIndex) And mask
' 每 step 向右移 8 位
For i = 1 To 3 - idxOffset
OSIndex = OSIndex / &H100
Next i
If n <= 12 Then
OSValue = solarTermOS(OSIndex * 2)
OSOffset = n
Else
OSValue = solarTermOS(OSIndex * 2 + 1)
OSOffset = n - 12
End If
mask = &H3&
' 每 step 向右移 2 位
For i = OSOffset To 11
mask = mask * &H4
Next i
OSValue = OSValue And mask
' 每 step 向左移 2 位
For i = OSOffset To 11
OSValue = OSValue / &H4
Next i
' 基准日期 + 偏差天数
GetSolarTerm = OSValue + solarTermBase(n - 1)
End Function
'#### 传入公历日期，返回农历日期 (公历1900/1/1~农历1900/1/1之间的日期尚待处理）
Public Function GetLunar(ByVal dt As Date) As LunarDate
Dim result As LunarDate
Dim lunarYearFirstDay As Date, mask As Long, i As Integer
Dim y As Integer, daysOfMonth As Integer, leapMonth As Integer, gregorianDay As Integer, n As Integer
y = DatePart("yyyy", dt)
If y < LUNAR_YEAR_START Or y > LUNAR_YEAR_END Then
Err.Raise Number:=6, DESCRIPTION:="只接受 " & LUNAR_YEAR_START & " - " & LUNAR_YEAR_END & " 之间的公历日期"
Exit Function
End If
lunarYearFirstDay = dateOfLunarYearBegin(y - LUNAR_YEAR_START)
If lunarYearFirstDay > dt Then
result.year = y - 1
lunarYearFirstDay = dateOfLunarYearBegin(result.year - LUNAR_YEAR_START)
Else
result.year = y
End If
result.day = DateDiff("d", lunarYearFirstDay, dt) + 1
leapMonth = GetLeapMonth(result.year)
mask = &H8000&
For i = 1 To 12
' 正常月份
daysOfMonth = GetLunarMonthDays(result.year, mask)
If result.day > daysOfMonth Then
result.day = result.day - daysOfMonth
Else
result.month = i
Exit For
End If
' 闰月
If leapMonth = i Then
daysOfMonth = GetLeapDays(result.year)
If result.day > daysOfMonth Then
result.day = result.day - daysOfMonth
Else
result.month = i
result.isLeap = True
Exit For
End If
End If
mask = mask / 2
Next i
' 二十四节气
n = (DatePart("m", dt) - 1) * 2
gregorianDay = DatePart("d", dt)
If gregorianDay > 15 Then
n = n + 2
Else
n = n + 1
End If
If GetSolarTerm(y, n) = gregorianDay Then
result.solarIndex = n
Else
result.solarIndex = 0
End If
GetLunar = result
End Function
'#### 类初始化，数据准备
Private Sub Class_Initialize()
Dim i As Integer, itemCount As Integer, sum As Long
compressLunarInfo = Array( _
&H4BD8&, &H4AE0&, &HA570&, &H54D5&, &HD260&, &HD950&, &H5554&, &H56AF&, &H9AD0&, &H55D2&, _
&H4AE0&, &HA5B6&, &HA4D0&, &HD250&, &HD295&, &HB54F&, &HD6A0&, &HADA2&, &H95B0&, &H4977&, _
&H497F&, &HA4B0&, &HB4B5&, &H6A50&, &H6D40&, &HAB54&, &H2B6F&, &H9570&, &H52F2&, &H4970&, _
&H6566&, &HD4A0&, &HEA50&, &H6A95&, &H5ADF&, &H2B60&, &H86E3&, &H92EF&, &HC8D7&, &HC95F&, _
&HD4A0&, &HD8A6&, &HB55F&, &H56A0&, &HA5B4&, &H25DF&, &H92D0&, &HD2B2&, &HA950&, &HB557&, _
&H6CA0&, &HB550&, &H5355&, &H4DAF&, &HA5B0&, &H4573&, &H52BF&, &HA9A8&, &HE950&, &H6AA0&, _
&HAEA6&, &HAB50&, &H4B60&, &HAAE4&, &HA570&, &H5260&, &HF263&, &HD950&, &H5B57&, &H56A0&, _
&H96D0&, &H4DD5&, &H4AD0&, &HA4D0&, &HD4D4&, &HD250&, &HD558&, &HB540&, &HB6A0&, &H95A6&, _
&H95BF&, &H49B0&, &HA974&, &HA4B0&, &HB27A&, &H6A50&, &H6D40&, &HAF46&, &HAB60&, &H9570&, _
&H4AF5&, &H4970&, &H64B0&, &H74A3&, &HEA50&, &H6B58&, &H5AC0&, &HAB60&, &H96D5&, &H92E0&, _
&HC960&, &HD954&, &HD4A0&, &HDA50&, &H7552&, &H56A0&, &HABB7&, &H25D0&, &H92D0&, &HCAB5&, _
&HA950&, &HB4A0&, &HBAA4&, &HAD50&, &H55D9&, &H4BA0&, &HA5B0&, &H5176&, &H52BF&, &HA930&, _
&H7954&, &H6AA0&, &HAD50&, &H5B52&, &H4B60&, &HA6E6&, &HA4E0&, &HD260&, &HEA65&, &HD530&, _
&H5AA0&, &H76A3&, &H96D0&, &H4AFB&, &H4AD0&, &HA4D0&, &HD0B6&, &HD25F&, &HD520&, &HDD45&, _
&HB5A0&, &H56D0&, &H55B2&, &H49B0&, &HA577&, &HA4B0&, &HAA50&, &HB255&, &H6D2F&, &HADA0&, _
&H4B63&, &H937F&, &H49F8&, &H4970&, &H64B0&, &H68A6&, &HEA5F&, &H6B20&, &HA6C4&, &HAAEF&, _
&H92E0&, &HD2E3&, &HC960&, &HD557&, &HD4A0&, &HDA50&, &H5D55&, &H56A0&, &HA6D0&, &H55D4&, _
&H52D0&, &HA9B8&, &HA950&, &HB4A0&, &HB6A6&, &HAD50&, &H55A0&, &HABA4&, &HA5B0&, &H52B0&, _
&HB273&, &H6930&, &H7337&, &H6AA0&, &HAD50&, &H4B55&, &H4B6F&, &HA570&, &H54E4&, &HD260&, _
&HE968&, &HD520&, &HDAA0&, &H6AA6&, &H56DF&, &H4AE0&, &HA9D4&, &HA4D0&, &HD150&, &HF252&, _
&HD520&)
' 取得各农历年的正月初一的公历日期
itemCount = UBound(compressLunarInfo)
ReDim dateOfLunarYearBegin(itemCount)
dateOfLunarYearBegin(0) = DateSerial(LUNAR_YEAR_START, FL_M, FL_D)
For i = 0 To itemCount - 1
sum = GetMultiLunarMonthDays(i + LUNAR_YEAR_START, 12)
dateOfLunarYearBegin(i + 1) = DateAdd("d", sum, dateOfLunarYearBegin(i))
'Debug.Print (i + LUNAR_YEAR_START + 1) & "年正月初一的公历日期：" & vbTab & dateOfLunarYearBegin(i + 1)
Next i
' 二十四节气在各月的基准日期
solarTermBase = Array(4, 19, 3, 18, 4, 19, 4, 19, 4, 20, 4, 20, 6, 22, 6, 22, 6, 22, 7, 22, 6, 21, 6, 21)
' 二十四节气以年为单位，在1900-2100年间，共有69种分布种类，一个长整型存储12个节气与基准日的天数差额，共2*69项(每2bit表示一个节气的天数差，0-3天，高8位置0)
solarTermOS = Array( _
&H95A59A, &H599AA5, &HA5A6AA, &H9AAAA9, &HA9AAAE, &HAAAAAA, &HAAFAEE, &HAEEAAA, &HEAA59A, &H599AA5, &HA9AAAA, &HAAAAAA, &HEAA59A, &H599A95, &H95A6AA, &H9A9AA9, _
&HA5A6AA, &HAAAAAA, &HAABAAE, &HAAEAAA, &HAAA59A, &H599695, &H95A69A, &H9A9AA9, &HA5A6AA, &HAAAAA9, &H95A59A, &H9A9AA5, &HA9AAAE, &HAAEAAA, &HAAA59A, &H599555, _
&HAAA599, &H599555, &HAAA559, &H599555, &H95A59A, &H599695, &HAA6559, &H559555, &H55A59A, &H599695, &H95A59A, &H9A9AA9, &HAA5559, &H559555, &HA95559, &H555555, _
&H55A599, &H599555, &HA95555, &H555555, &H55A559, &H599555, &HA5A6AA, &H9A9AA9, &HA95155, &H555555, &H55A559, &H559555, &H95A59A, &H5996A5, &HA55155, &H455555, _
&H556559, &H559555, &H95A59A, &H5A9AA5, &HA55155, &H455554, &H555559, &H555555, &H55A599, &H599695, &H545559, &H555555, &H545555, &H595555, &H545555, &H555555, _
&HA55155, &H454554, &H545155, &H555555, &HA55145, &H454554, &H545155, &H455555, &H955045, &H454554, &H505155, &H455555, &H955045, &H44554, &H505155, &H455554, _
&H955045, &H44550, &H505145, &H454554, &H955045, &H44150, &H505045, &H454554, &H955044, &H44140, &H405045, &H44554, &H555044, &H44140, &H555555, &H555555, _
&H405045, &H44550, &H555044, &H44000, &H555004, &H4000&, &H405045, &H44150, &H505045, &H54554, &H405044, &H44140, &H505045, &H44554, &H550004, &H0&, _
&H5044&, &H44140, &H550000, &H0&, &H5044&, &H44000, &H540000, &H0&, &H5044&, &H4000&)
' 1900-2100各年的二十四节气分布种类，对应上表中的序号，一个长整型保存4年序号，每8bit一个序号（序号=0-68)
solarTermIdx = Array( _
&H10203, &H4010503, &H4010503, &H6070809, &HA0B0C09, &HA0D0C0E, &HA0D010E, &HF000102, &H10000105, &H10000105, _
&H10000105, &H11120708, &H13141508, &H13140D01, &H16140001, &H17180001, &H17180001, &H19180001, &H191A001B, &H1C1D1E0B, _
&H1C1D1215, &H1F201421, &H22232400, &H22251800, &H22261800, &H22271800, &H22271D00, &H28291D1E, &H2A2B1D12, &H2C2D2024, _
&H2E2F2324, &H302F2718, &H302F2718, &H302F271D, &H302F271D, &H3031291D, &H32332B1D, &H34352D23, &H36352D37, &H36382F37, _
&H39382F27, &H39382F27, &H3A383127, &H3A3B312B, &H3A3B3C2B, &H3A3D3E2D, &H3F40352D, &H4140382F, &H4142382F, &H4344382F, _
&H27000000)
End Sub
'#### 取得 y 年从农历正月初一到 m 月月底的总天数
Private Function GetMultiLunarMonthDays(y As Long, m As Long) As Long
Dim i As Integer, mask As Long, sum As Long, leapMonth As Integer
If m < 1 Then
GetMultiLunarMonthDays = 0
Exit Function
End If
mask = &H8000&
sum = 0
i = 1
' 各正常月份天数累加
While (i <= m) And (mask > &H8)
sum = sum + GetLunarMonthDays(y, mask)
mask = mask / 2
i = i + 1
Wend
' 闰月天数累加
leapMonth = GetLeapMonth(y)
If leapMonth > 0 And leapMonth < m Then
sum = sum + GetLeapDays(y)
End If
GetMultiLunarMonthDays = sum
End Function
'#### 返回 y 年指定月份的天数
Private Function GetLunarMonthDays(y As Long, ByVal mask As Long) As Long
If (compressLunarInfo(y - LUNAR_YEAR_START) And mask) = mask Then
GetLunarMonthDays = 30
Else
GetLunarMonthDays = 29
End If
End Function
'#### 返回 y 年闰月的天数
Private Function GetLeapDays(y As Long) As Long
If (compressLunarInfo(y - LUNAR_YEAR_START + 1) And &HF) = &HF Then
GetLeapDays = 30
Else
GetLeapDays = 29
End If
End Function
'#### 返回 y 年闰月的月份，1-12，没闰传回 0
Private Function GetLeapMonth(y As Long) As Long
Dim leapMonth As Long
leapMonth = (compressLunarInfo(y - LUNAR_YEAR_START) And &HF)
If leapMonth = &HF Then
GetLeapMonth = 0
Else
GetLeapMonth = leapMonth
End If
End Function