VBA农历转公历

10 篇文章 0 订阅

  • 基础知识:

    农历是阴阳合历,每年有12个月,大月30天,小月29天,如果有闰月,闰月也分大小月,也是30天或29天。一年有24节气,节气以太阳运转轨迹为准,基本原则是每月两个节气,分别在月首3号左右,月尾24号左右。闰月通常设置在只有一个节气的月份之后。农历新年,是以24节气的立春为界,立春后开始新的一年。


  • 编程设计:

    编程源代码原型:http://s.o4u.com/host/blog/calendar/calendar.htm  Sean Lin (林洵賢)

    以一个整数数组来保存各农历年的12个月大小月情况,以及闰月月份,闰月大小月,通过查表方式,计算农历日期。

    例:1900年的数据为 &H4BD8,用二进制表示:

以字为单位。

前12个bit,依次表示1-12月份的大小月,1为大月30天,0为小月29天

后4bit分为两种情况:

  1、闰月的月份(如1000,二进制转为十进制为8,表示该年闰八月)

  2、前一年闰月的大小月标志(二进制0000表示闰小月,二进制1111表示闰大月)

         闰月大小月与当前年份不在一起,而是在下一年的数据中,但不会产生冲突,是因为相邻两年,不可能同为闰月年。


编程思路:

    取给定农历与年初正月初一的天数,再在年初公历日期的基础上,加上相差的天数,取得新的公历日期即可;如果要由公历得到农历,则反一下即可。


  • VBA类代码:

'
'根据农历年月日取对应公历日期 类模块
'                                    (By 漠石 mostone@hotmail.com)
'
'  本类只有一个公用方法:
'    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 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 GetDateFromLunar(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
    
    GetDateFromLunar = DateAdd("d", sum, dateOfLunarYearBegin(y - LUNAR_YEAR_START))
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
    
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

-完-

评论 3 您还未登录,请先 登录 后发表或查看评论

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
©️2022 CSDN 皮肤主题:撸撸猫 设计师:马嘣嘣 返回首页

打赏作者

mostone

你的鼓励将是我创作的最大动力

¥2 ¥4 ¥6 ¥10 ¥20
输入1-500的整数
余额支付 (余额:-- )
扫码支付
扫码支付:¥2
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值