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: [e-mail]
'           [e-mail]
'   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