公农历转换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)) & "年"

     End If

    Else

     If y <= 1910 Then

       tempStr = "清朝宣统"

       If y = 1909 Then

        tempStr = tempStr & "元年"

       Else

        tempStr = tempStr & UpNumber(CStr(y - 1909 + 1)) & "年"

       End If

     Else

       If y < 1949 Then

        tempStr = "中华民国"

        If y = 1912 Then

          tempStr = tempStr & "元年"

        Else

          tempStr = tempStr & UpNumber(CStr(y - 1912 + 1)) & "年"

        End If

       Else

        tempStr = "中华人民共和国成立"

        If y = 1949 Then

          tempStr = tempStr & "了"

        Else

          Select Case y

           Case 2000

             tempStr = "千禧年"

           Case Else

             tempStr = tempStr & UpNumber(CStr(y - 1949)) & "周年"

          End Select

        End If

       End If

     End If

    End If

  End If

  Era = tempStr

End Function

' 传入 num 传回干支, 0=甲子

Public Function GanZhi(num As Long) As String

  Dim tempStr As String

  Dim i As Long

  i = (num - 1864) Mod 60 '计算干支

  tempStr = Gan(i Mod 10) & Zhi(i Mod 12)

  GanZhi = tempStr

End Function

'计算年的属相字串

Public Function YearAttribute(y As Long) As String

  YearAttribute = Animals((y - 1900) Mod 12)

End Function

'将数字汉化

Public Function UpNumber(Dxs As String) As String

'检测为空时

If Trim(Dxs) = "" Then

  UpNumber = ""

  Exit Function

End If

Dim Sw As Integer, SzUp As Integer, tempStr As String, DXStr As String

  Sw = Len(Trim(Dxs))

   Dim i As Integer

   For i = 1 To Sw

     tempStr = Right(Trim(Dxs), i)

     tempStr = Left(tempStr, 1)

     tempStr = Converts(tempStr)

     Select Case i

      Case 1

        If tempStr = "零" Then

         tempStr = ""

          Else

         tempStr = tempStr + ""

        End If

      Case 2

        If tempStr = "零" Then

         tempStr = "零"

        Else

         tempStr = tempStr + "十"

        End If

      Case 3

        If tempStr = "零" Then

         tempStr = "零"

          Else

         tempStr = tempStr + "百"

        End If

      Case 4

        If tempStr = "零" Then

         tempStr = "零"

          Else

         tempStr = tempStr + "千"

        End If

      Case 5

        If tempStr = "零" Then

         tempStr = "万"

          Else

         tempStr = tempStr + "万"

        End If

      Case 6

        If tempStr = "零" Then

         tempStr = "零"

          Else

         tempStr = tempStr + "十"

        End If

      Case 7

        If tempStr = "零" Then

         tempStr = "零"

          Else

         tempStr = tempStr + "百"

        End If

      Case 8

        If tempStr = "零" Then

         tempStr = "零"

          Else

         tempStr = tempStr + "千"

        End If

      Case 9

        If tempStr = "零" Then

         tempStr = "亿"

          Else

         tempStr = tempStr + "亿"

        End If

     End Select

  Dim TempA As String

    TempA = Left(Trim(DXStr), 1)

  If tempStr = "零" Then

   Select Case TempA

    Case "零"

      DXStr = DXStr

    Case "万"

      DXStr = DXStr

    Case "亿"

      DXStr = DXStr

    Case Else

      DXStr = tempStr + DXStr

   End Select

   Else

    DXStr = tempStr + DXStr

  End If

   Next

  UpNumber = DXStr

End Function

Private Function Converts(NumStr As String) As String

  Select Case val(NumStr)

   Case 0

    Converts = "零"

   Case 1

    Converts = "一"

   Case 2

    Converts = "二"

   Case 3

    Converts = "三"

   Case 4

    Converts = "四"

   Case 5

    Converts = "五"

   Case 6

     Converts = "六"

   Case 7

     Converts = "七"

   Case 8

     Converts = "八"

   Case 9

     Converts = "九"

  End Select

End Function

'中文日期

Public Function CDayStr(d As Long) As String

  Dim s As String

  Select Case d

   Case 0

    s = ""

   Case 10

    s = "初十"

   Case 20

    s = "二十"

   Case 30

    s = "三十"

   Case Else

    s = nStr2(d \ 10) '整数除法

    s = s & nStr1(d Mod 10)

  End Select

  CDayStr = s

End Function

'计算星座归属

Public Function Constellation(m As Long, d As Long) As String

  Dim y As Long

  Dim tempDate As Date

  Dim ConstellName As String

  y = 2000

  tempDate = m & "/" & d & "/" & y

  Select Case tempDate

   Case #3/21/2003# To #4/19/2000#

      ConstellName = "白羊"

   Case #4/20/2000# To #5/20/2000#

      ConstellName = "金牛"

   Case #5/21/2000# To #6/21/2000#

      ConstellName = "双子"

   Case #6/22/2000# To #7/22/2000#

      ConstellName = "巨蟹"

   Case #7/23/2000# To #8/22/2000#

      ConstellName = "狮子"

   Case #8/23/2000# To #9/22/2000#

      ConstellName = "处女"

   Case #9/23/2000# To #10/23/2000#

      ConstellName = "天秤"

   Case #10/24/2000# To #11/21/2000#

      ConstellName = "天蝎"

   Case #11/22/2000# To #12/21/2000#

      ConstellName = "射手"

   Case #12/22/2000# To #