真正的公農歷轉換類for VB     選擇自 BlueDog 的 Blog  
關鍵字   公農歷 VB 類 
出處    
 
     公農歷轉換VB類  clsDate
 
    網上流傳很多計算公農歷的源代碼，很多，但是居然沒有VB的，暈，
    所以。。。。。
    
    用法：
    以l開始的方法均為陰歷，以s開始的方法均為公歷
    基本的兩個初使函數：
    lInitDate：用農歷年月日初使化日期對象
    sInitDate: 用公歷年月日初使化日期對象
    
    其它的方法看下面的一小段代碼吧

示例代碼    
Private Sub Command1_Click()
   Dim t As clsDate
   Dim y As Long
   Dim m As Long
   Dim d As Long
   Dim st As Single
   Dim et As Single
   Dim da As Date
   Dim j As Long
   Dim ret As Long
   Set t = New clsDate
   't.sInitDate 1900, 1, 1
   t.lInitDate 2047, 5, 12, False   '農歷2047年5月12日，非閏月
   Debug.Print t.lYear
   If t.IsLeap = False Then
      Debug.Print t.lMonth
   Else
      Debug.Print " 閏 " & t.lMonth
   End If
   Debug.Print t.CDayStr(t.lDay)  '農歷日期中文大寫
   Debug.Print t.GanZhi(t.lYear)  '求干支
   Debug.Print t.YearAttribute(t.lYear) '農歷年的屬相
   Debug.Print t.sYear ' 公歷年
   Debug.Print t.sMonth ' 公歷月
   Debug.Print t.sDay ' 公歷日
   Debug.Print t.sWeekDay '公歷星期
   Debug.Print t.Era(t.sYear)' 公歷紀元
   Debug.Print t.Constellation(t.sMonth, t.sDay) ' 星座
   Debug.Print "Week:" & t.wHoliday ' 按第幾個星期幾計算的假日
   Debug.Print "Solar" & t.sHoliday ' 按公歷計算的假日
   Debug.Print "Lunar" & t.lHoliday ' 按陰歷計算的假日
   Debug.Print t.lSolarTerm ' 計算節氣
   
   '以下為速度測試，很快吧。
   st = Timer
   With t
        For y = 1900 To 2049
           For m = 1 To 12
             For d = 1 To 28
                .lInitDate y, m, d, False
   
             Next
           Next
        Next
   End With
   't.printf
   et = Timer
   Debug.Print et - st

   Set t = Nothing
End Sub    
    
‘///////////////////////////////////////////////////////////////////////////////
'
' 以下為源代碼部分，如果你需要在你的程序中使用，請在你寫一封E-mail給我，至少讓我知道有人
' 還在用它。
'
'   E-mail: lxs@xtcz.net
'           zhenghesoft@hotmail.com
'   QQ:     248241571
'                                         BlueDog  即日            
’
Option Explicit

' ///////////////////////////////////////////////////////////////////////////////
' //                                                                           //
' //                                                                           //
' // 說明:本模塊僅能用于1900.1.31日起至 2049.12.31日止的數據轉換,否則會出錯。  //
' //            或者農力1900.1.1日起至2049.12.7日止                            //
' //                                                                           //
' //                           2003.10.21                                      //
' //                                                                           //
' ///////////////////////////////////////////////////////////////////////////////

Private Type SolarHolidayStruct
    Month As Long
    Day As Long
    Recess As Long
    HolidayName As String
End Type

Private Type LunarHolidayStruct
    Month As Long
    Day As Long
    Recess As Long
    HolidayName As String
End Type

Private Type WeekHolidayStruct
    Month As Long
    WeekAtMonth As Long
    WeekDay As Long
    HolidayName As String
End Type

'保持屬性值的局部變量
Private mvarsYear As Long '局部復制
Private mvarsMonth As Long '局部復制
Private mvarsDay As Long '局部復制
Private mvarlYear As Long '局部復制
Private mvarlMonth As Long '局部復制
Private mvarlDay As Long '局部復制
Private mvarIsLeap As Boolean '局部復制

Private Declare Function BitRight32 Lib "Bit4VB.DLL" (ByVal x As Long, ByVal num As Long) As Long
'Private Declare Function BitRight16 Lib "Bit4VB.DLL" (ByVal x As Integer, ByVal num As Integer) As Integer

'定義類內部用公用變量

Private SolarMonth As Variant
Private Gan As Variant
Private Zhi As Variant
Private Animals As Variant
Private SolarTerm As Variant
Private sTermInfo As Variant
Private nStr1 As Variant
Private nStr2 As Variant
Private MonthName As Variant
Private LunarInfo(150) As Long
Private LunarYearDays(150) As Long
Private sHolidayInfo() As SolarHolidayStruct
Private lHolidayInfo() As LunarHolidayStruct
Private wHolidayInfo() As WeekHolidayStruct

Private mvarDate As Date '內部使用標準的日期變量


Private Sub Class_Initialize()
   Dim tempArray As Variant
   Dim i As Long
   Dim b As Long
   Dim sFtv As Variant
   Dim lFtv As Variant
   Dim wFtv As Variant

   '根據VB的位計算特點,故擴充原有的數據位,將其變成32位
   tempArray = Array( _
        &H104BD8, &H104AE0, &H10A570, &H1054D5, &H10D260, &H10D950, &H116554, &H1056A0, &H109AD0, &H1055D2, _
        &H104AE0, &H10A5B6, &H10A4D0, &H10D250, &H11D255, &H10B540, &H10D6A0, &H10ADA2, &H1095B0, &H114977, _
        &H104970, &H10A4B0, &H10B4B5, &H106A50, &H106D40, &H11AB54, &H102B60, &H109570, &H1052F2, &H104970, _
        &H106566, &H10D4A0, &H10EA50, &H106E95, &H105AD0, &H102B60, &H1186E3, &H1092E0, &H11C8D7, &H10C950, _
        &H10D4A0, &H11D8A6, &H10B550, &H1056A0, &H11A5B4, &H1025D0, &H1092D0, &H10D2B2, &H10A950, &H10B557, _
        &H106CA0, &H10B550, &H115355, &H104DA0, &H10A5D0, &H114573, &H1052D0, &H10A9A8, &H10E950, &H106AA0, _
        &H10AEA6, &H10AB50, &H104B60, &H10AAE4, &H10A570, &H105260, &H10F263, &H10D950, &H105B57, &H1056A0, _
        &H1096D0, &H104DD5, &H104AD0, &H10A4D0, &H10D4D4, &H10D250, &H10D558, &H10B540, &H10B5A0, &H1195A6, _
        &H1095B0, &H1049B0, &H10A974, &H10A4B0, &H10B27A, &H106A50, &H106D40, &H10AF46, &H10AB60, &H109570, _
        &H104AF5, &H104970, &H1064B0, &H1074A3, &H10EA50, &H106B58, &H1055C0, &H10AB60, &H1096D5, &H1092E0, _
        &H10C960, &H10D954, &H10D4A0, &H10DA50, &H107552, &H1056A0, &H10ABB7, &H1025D0, &H1092D0, &H10CAB5, _
        &H10A950, &H10B4A0, &H10BAA4, &H10AD50, &H1055D9, &H104BA0, &H10A5B0, &H115176, &H1052B0, &H10A930, _
        &H107954, &H106AA0, &H10AD50, &H105B52, &H104B60, &H10A6E6, &H10A4E0, &H10D260, &H10EA65, &H10D530, _
        &H105AA0, &H1076A3, &H1096D0, &H104BD7, &H104AD0, &H10A4D0, &H11D0B6, &H10D250, &H10D520, &H10DD45, _
        &H10B5A0, &H1056D0, &H1055B2, &H1049B0, &H10A577, &H10A4B0, &H10AA50, &H11B255, &H106D20, &H10ADA0)
   For i = 0 To 149
     LunarInfo(i) = tempArray(i)
   Next
   
   tempArray = Array( _
                384, 354, 355, 383, 354, 355, 384, 354, 355, 384, _
                354, 384, 354, 354, 384, 354, 355, 384, 355, 384, _
                354, 354, 384, 354, 354, 385, 354, 355, 384, 354, _
                383, 354, 355, 384, 355, 354, 384, 354, 384, 354, _
                354, 384, 355, 354, 385, 354, 354, 384, 354, 384, _
                354, 355, 384, 354, 355, 384, 354, 383, 355, 354, _
                384, 355, 354, 384, 355, 353, 384, 355, 384, 354, _
                355, 384, 354, 354, 384, 354, 384, 354, 355, 384, _
                355, 354, 384, 354, 384, 354, 354, 384, 355, 355, _
                384, 354, 354, 383, 355, 384, 354, 355, 384, 354, _
                354, 384, 354, 355, 384, 354, 385, 354, 354, 384, _
                354, 354, 384, 355, 384, 354, 355, 384, 354, 354, _
                384, 354, 355, 384, 354, 384, 354, 354, 384, 355, _
                354, 384, 355, 384, 354, 354, 384, 354, 354, 384, _
                355, 355, 384, 354, 384, 354, 354, 384, 354, 355)
   
   For i = 0 To 149
     LunarYearDays(i) = tempArray(i)
   Next
   
   SolarMonth = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
   Gan = Array("甲", "乙", "丙", "丁", "戊", "己", "庚", "辛", "壬", "癸")
   Zhi = Array("子", "丑", "寅", "卯", "辰", "巳", "午", "未", "申", "酉", "戌", "亥")
   Animals = Array("鼠", "牛", "虎", "兔", "龍", "蛇", "馬", "羊", "猴", "雞", "狗", "豬")
   SolarTerm = Array("小寒", "大寒", "立春", "雨水", "驚蟄", "春分", "清明", "谷雨", "立夏", "小滿", "芒種", "夏至", "小暑", "大暑", "立秋", "處暑", "白露", "秋分", "寒露", "霜降", "立冬", "小雪", "大雪", "冬至")
   sTermInfo = Array(0, 21208, 42467, 63836, 85337, 107014, 128867, 150921, 173149, 195551, 218072, 240693, 263343, 285989, 308563, 331033, 353350, 375494, 397447, 419210, 440795, 462224, 483532, 504758)
   nStr1 = Array("日", "一", "二", "三", "四", "五", "六", "七", "八", "九", "十")
   nStr2 = Array("初", "十", "廿", "卅", "　")
   MonthName = Array("JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC")
   
   '國歷節日 *表示放假日
   sFtv = Array( _
        1, 1, 1, "元旦", _
        2, 14, 0, "情人節", 2, 10, 0, "國際氣象節", _
        3, 18, 0, "婦女節", 3, 12, 0, "植樹節", 3, 15, 0, "消費者權益日", _
        4, 1, 0, "愚人節", _
        5, 1, 1, "勞動節", 5, 4, 0, "青年節", 5, 12, 0, "護士節", 5, 31, 0, "世界無煙日", _
        6, 1, 0, "兒童節", _
        7, 1, 0, "建黨節 香港回歸紀念", _
        8, 1, 0, "建軍節", 8, 8, 0, "中國男子節 父親節", _
        9, 9, 0, "毛澤東逝世紀念", 9, 10, 0, "教師節", 9, 18, 0, "九·一八事變紀念日", 9, 28, 0, "孔子誕辰", _
        10, 1, 0, "國慶節 國際音樂日", 10, 6, 0, "老人節", 10, 24, 0, "聯合國日", _
        11, 12, 0, "孫中山誕辰紀念", _
        12, 1, 0, "世界艾滋病日", 12, 3, 0, "世界殘疾人日", 12, 20, 0, "澳門回歸紀念", 12, 24, 0, "平安夜", 12, 25, 0, "圣誕節", 12, 26, 0, "毛澤東誕辰紀念")
        
   b = UBound(sFtv) + 1
   ReDim sHolidayInfo(b / 4)
   For i = 0 To (b / 4) - 1
       sHolidayInfo(i).Month = sFtv(i * 4)
       sHolidayInfo(i).Day = sFtv(i * 4 + 1)
       sHolidayInfo(i).Recess = sFtv(i * 4 + 2)
       sHolidayInfo(i).HolidayName = sFtv(i * 4 + 3)
   Next
   
   '農歷節日 *表示放假日
   lFtv = Array( _
        1, 1, 1, "春節", _
        1, 15, 0, "元宵節", _
        5, 5, 0, "端午節", _
        7, 7, 0, "七夕情人節", _
        7, 15, 0, "中元節 盂蘭盆節", _
        8, 15, 0, "中秋節", _
        9, 9, 0, "重陽節", _
        12, 8, 0, "臘八節", _
        12, 24, 0, "小年")
        '12, 31, 0, "除夕")  '注意除夕需要其它方法進行計算
   
   b = UBound(lFtv) + 1
   ReDim lHolidayInfo(b / 4)
   For i = 0 To (b / 4) - 1
       lHolidayInfo(i).Month = lFtv(i * 4)
       lHolidayInfo(i).Day = lFtv(i * 4 + 1)
       lHolidayInfo(i).Recess = lFtv(i * 4 + 2)
       lHolidayInfo(i).HolidayName = lFtv(i * 4 + 3)
   Next
   
   '某月的第幾個星期幾
   wFtv = Array( _
       5, 2, 1, "國際母親節", _
       5, 3, 1, "全國助殘日", _
       6, 3, 1, "父親節", _
       9, 3, 3, "國際和平日", _
       9, 4, 1, "國際聾人節", _
       10, 1, 2, "國際住房日", _
       10, 1, 4, "國際減輕自然災害日", _
       11, 4, 5, "感恩節")
   b = UBound(wFtv) + 1
   ReDim wHolidayInfo(b / 4)
   For i = 0 To (b / 4) - 1
       wHolidayInfo(i).Month = wFtv(i * 4)
       wHolidayInfo(i).WeekAtMonth = wFtv(i * 4 + 1)
       wHolidayInfo(i).WeekDay = wFtv(i * 4 + 2) '1 代表星期天
       wHolidayInfo(i).HolidayName = wFtv(i * 4 + 3)
   Next
End Sub

'/////////////////////////////////////////////////////////////////////////////////////////////////////////////

'計算農歷上的節氣
Public Property Get lSolarTerm() As String

    '//===== 某年的第n個節氣為幾日(從0小寒起算)
    'function sTerm(y,n) {
    '   var offDate = new Date( ( 31556925974.7*(y-1900) + sTermInfo[n]*60000  ) + Date.UTC(1900,0,6,2,5) )
    '   return(offDate.getUTCDate())

    '//節氣
    '   tmp1 = sTerm(y, m * 2) - 1
    
    Dim baseDateAndTime As Date
    Dim newDate As Date
    Dim num As Double
    Dim y As Long
    Dim tempStr As String
    
    baseDateAndTime = #1/6/1900 2:05:00 AM#
    y = mvarsYear
    tempStr = ""
    
    Dim i As Long
    For i = 1 To 24
       num = 525948.76 * (y - 1900) + sTermInfo(i - 1)
       newDate = DateAdd("n", num, baseDateAndTime)  '按分鐘計算,之所以不按秒鐘計算，是因為會溢出
       If Abs(DateDiff("d", newDate, mvarDate)) = 0 Then
          tempStr = SolarTerm(i - 1)
          Exit For
       End If
    Next
  
    lSolarTerm = tempStr
End Property
'計算按第幾周星期幾計算的節日
Public Property Get wHoliday() As String
    Dim w As Long
    Dim i As Long
    Dim b As Long
    Dim FirstDay As Date
    Dim tempStr As String
    
    b = UBound(wHolidayInfo)
    For i = 0 To b
      If wHolidayInfo(i).Month = mvarsMonth Then  '當月份相當時
         w = WeekDay(mvarDate)
         If wHolidayInfo(i).WeekDay = w Then  '僅當星期幾也相等時
            FirstDay = mvarsMonth & "/" & 1 & "/" & mvarsYear '取當月第一天
            If (DateDiff("ww", FirstDay, mvarDate) = wHolidayInfo(i).WeekAtMonth) Then
                tempStr = wHolidayInfo(i).HolidayName
            End If
         End If
      End If
    Next
    
    
    wHoliday = tempStr
End Property

Public Property Get lHoliday() As String
    Dim i As Long
    Dim b As Long
    Dim tempStr As String
    Dim oy As Long
    Dim odate As Date
    Dim ndate As Date
    
    tempStr = ""
    b = UBound(lHolidayInfo)
    If mvarlMonth = 12 And (mvarlDay = 29 Or mvarlDay = 30) Then
       '保
       oy = mvarlYear '保存農歷年數
       odate = mvarDate
       ndate = mvarDate + 1
       Call sInitDate(Year(ndate), Month(ndate), Day(ndate)) '計算第二天的屬性
       If oy = mvarlYear - 1 Then '如果農歷年數增加了1
          tempStr = "除夕"
          Call sInitDate(Year(odate), Month(odate), Day(odate)) '恢復到今天原有數據
          
       End If
    Else
        For i = 0 To b
           If (lHolidayInfo(i).Month = mvarlMonth) And _
              (lHolidayInfo(i).Day = mvarlDay) Then
               tempStr = lHolidayInfo(i).HolidayName
               Exit For
           End If
        Next
    End If
    lHoliday = tempStr
End Property
'求公歷節日
Public Property Get sHoliday() As String
    Dim i As Long
    Dim b As Long
    Dim tempStr As String
    
    tempStr = ""
    b = UBound(sHolidayInfo)
    For i = 0 To b
       If (sHolidayInfo(i).Month = mvarsMonth) And _
          (sHolidayInfo(i).Day = mvarsDay) Then
           tempStr = sHolidayInfo(i).HolidayName
           Exit For
       End If
    Next
    sHoliday = tempStr
End Property
'是否是農歷的閏月
Public Property Get IsLeap() As Boolean
    IsLeap = mvarIsLeap
End Property

Public Property Get lDay() As Long
    lDay = mvarlDay
End Property

Public Property Get lMonth() As Long
    lMonth = mvarlMonth
End Property

Public Property Get lYear() As Long
    lYear = mvarlYear
End Property
Public Property Get sWeekDay() As Long
    sWeekDay = WeekDay(mvarDate)
End Property

Public Property Get sDay() As Long
    sDay = mvarsDay
End Property

Public Property Get sMonth() As Long
    sMonth = mvarsMonth
End Property

Public Property Get sYear() As Long
    sYear = mvarsYear
End Property

'////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Function IsToday(y As Long, m As Long, d As Long) As Boolean
   
    If (Year(Date) = y) And _
       (Month(Date) = m) And _
       (Day(Date) = d) Then
        IsToday = True
    Else
        IsToday = False
    End If
    
End Function


'根據年份不同計算當年屬于什么朝代
Public Function Era(y As Long) As String
   Dim tempStr As String
   
   If y < 1874 Then
       tempStr = "未知"
   Else
       If y <= 1908 Then
          tempStr = "清朝光緒"
          If y = 1874 Then
            tempStr = tempStr & "元年"
          Else
            tempStr = tempStr & UpNumber(CStr(y - 1874)) & "年"