clsdate.cls

VB精美仿VISTA时钟

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsDate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ======================
'   好软件，蓝蓝小雪造
'  [e-mail]
'         502462725
'      www.snow518.cn
' ======================



'********************************************************************************************
'建一个类，类名为clsDate
Option Explicit
'                              作  者  的  话
'
'      clsDate本来是我在写一个软件的时候,因为需要,而且自已也想实作一个公农历的模块,因此就
'  写了它。2003年我将它发表在CSDN上，开始没有什么人注意，但是后来发现很多人写信给我说很不错，
'  我终于了解到了它的意义。所以也就打算一直把它维护下去。
'
'      因为我也是看到一个JSP的开源代码，我才了解它的原理，因此我也把这个小东东的源码公开了，
'  希望大家能够喜欢它。在这个类里有两个比较重要的问题需要解决，当你理解了它们，你就理解这个类
'  1、如何在VB中初使化数组数据
'       我采用的方式是   mydata =Array( , , , , )
'       或许你有更好的方法，虽然我也曾经想到用资源的方案，但是我觉得用户需要将资源导来导去，在
'  使用中会很不方便。
'  2、VB中的位操作是如何的
'      在1.0版中，也就是我发表在CSDN上的版本，其中需要一个Bit4VB.DLL的动态库，我是用C写的，
'  因为大家说VB是不能做位操作的，呵呵，我也没有去考虑那么多，就写了一个动态库。结果很多网友来信
'  有很大一半是要这个DLL的。
'      当我阅读Hardcore VB时，我才发现原来VB也是可以进行位操作的。如果计算到动态库的载入和接口处
'  理的花费的话，其实VB来写一个位操作的函数并不比用C来写慢多少。因此我实作出mvarBitTest32这个函数
'  在1.02中你再也不需要任何的DLL来支持这个类了。
'
'
'
'    最后我希望你能抽一点点时间给我写一封信，让我知道你在用它。让我有信心继续维护它。
'
'    E-mail:  [e-mail]      [e-mail]
'
'

'  版本预告：
'      下次我将推出 VB.net 和VB 6.0两个平台的版本。
'          将实现 1900-2100年的公农历转换
'          将一些方法和属性重新更名，但原有的接口将继续保持。
'
'  版本历史:
'  更新版本请注意CSDN上的更新
'
'
'  版本1.02   2004-4-15
'      考虑到用动态DLL的方案并不能真正提高位操作的速度,
'      而且受到Hardcore VB 作者的启示,已实作出速度很快的VB位操作模块,因此不再使用Bit4VB.DLL
'      在这个版本中只需要一个clsDate便真正可以完成公农历的转换,不需要其它任何的模块
'
'  版本 1.01  2004-2-10
'      增加了可以返回星期几字样的函数,sWeekDayStr
'      原来的sWeekDay 仍继续使用,以保证其它用户
'
'
'
'
'                                 注  意  事  项
'
' ///////////////////////////////////////////////////////////////////////////////
' //                                                                           //
' //                                                                           //
' // 说明:本模块仅能用于1900.1.31日起至 2049.12.31日止的数据转换,否则会出错。     //
' //            或者农历1900.1.1日起至2049.12.7日止                             //
' //                                                                           //
' ///////////////////////////////////////////////////////////////////////////////
'


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 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 BitPower(31) As Long '0-31

'位测试 ,测试位为1 返回真
Private Function mvarBitTest32(Number As Long, Bit As Long) As Boolean
    If Bit < 0 Or Bit > 31 Then '不是整数位
        mvarBitTest32 = False
    Else
        If Number And BitPower(Bit) Then
          mvarBitTest32 = True
        Else
          mvarBitTest32 = False
        End If
    End If
End Function

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, 2, 0, "世界湿地日", 2, 14, 0, "情人节", 2, 10, 0, "国际气象节", _
        3, 1, 0, "国际海豹日", 3, 5, 0, "学雷锋纪念日", 3, 8, 0, "妇女节", 3, 12, 0, "植树节 孙中山逝世纪念日", 3, 14, 0, "国际警察日", 3, 15, 0, "消费者权益日", 3, 17, 0, "中国国医节 国际航海日", 3, 21, 0, "世界森林日 消除种族歧视国际日 世界儿歌日", 3, 22, 0, "世界水日", 3, 24, 0, "世界防治结核病日", _
        4, 1, 0, "愚人节", 4, 28, 0, "08'胶济铁路火车相撞", 4, 7, 0, "世界卫生日", 4, 22, 0, "世界地球日", _
        5, 1, 1, "劳动节", 5, 4, 0, "青年节", 5, 12, 0, "08'汶川地震 护士节", 5, 31, 0, "世界无烟日", 5, 8, 0, "世界红十字日", 5, 12, 0, "国际护士节", _
        6, 1, 0, "儿童节", 6, 5, 0, "世界环境保护日", 6, 26, 0, "国际禁毒日", _
        7, 1, 0, "建党节 香港回归纪念 世界建筑日", 7, 11, 0, "世界人口日", _
        8, 1, 0, "建军节", 8, 8, 0, "中国男子节 父亲节", 8, 15, 0, "抗日战争胜利纪念", _
        9, 9, 0, "毛泽东逝世纪念", 9, 10, 0, "教师节", 9, 18, 0, "九·一八事变纪念日", 9, 28, 0, "孔子诞辰", 9, 20, 0, "国际爱牙日", 9, 27, 0, "世界旅游日", _
        10, 1, 0, "国庆节 国际音乐日", 10, 2, 1, "国庆节假日", 10, 3, 1, "国庆节假日", 10, 6, 0, "老人节", 10, 24, 0, "联合国日", _
        11, 12, 0, "孙中山诞辰纪念", 11, 3, 0, "本软件作者生日", 11, 1, 0, "国际旅游电影节", 11, 8, 0, "中国记者日", 11, 10, 0, "世界青年日", 11, 14, 0, "世界糖尿病日", 11, 17, 0, "世界学生节", _
        12, 1, 0, "世界艾滋病日", 12, 3, 0, "世界残疾人日", 12, 20, 0, "澳门回归纪念", 12, 24, 0, "平安夜", 12, 25, 0, "圣诞节", 12, 26, 0, "毛泽东诞辰纪念", 12, 9, 0, "世界足球日", 12, 10, 0, "世界人权日", 12, 13, 0, "南京大屠杀纪念日", _
        9, 3, 0, "抗日战争胜利日", 9, 17, 0, "国际和平日", 9, 20, 0, "全国爱牙日", 10, 8, 0, "全国高血压日", 10, 15, 0, "国际盲人节(白手杖日)", 10, 16, 0, "世界粮食日", 10, 31, 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, 1, "端午节", _
        7, 7, 0, "七夕情人节", _
        7, 15, 0, "中元节 盂兰盆节", _
        8, 15, 1, "中秋节", _
        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


   '位操作初使化模块函数 modBit4VB中定义
   For i = 0 To 30
      BitPower(i) = 2 ^ i
   Next
   BitPower(31) = &H80000000
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