clsdate.cls

VB精美仿VISTA时钟

    Dim b As Long
    Dim FirstDay As Date
    Dim TempStr As String
    TempStr = ""
    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 sHolidayRecess() As Boolean
    Dim i As Long
    Dim b As Long
    Dim TempStr As Boolean
    
    TempStr = False
    b = UBound(sHolidayInfo)
    For i = 0 To b
       If (sHolidayInfo(i).Month = mvarsMonth) And _
          (sHolidayInfo(i).Day = mvarsDay) Then
           TempStr = sHolidayInfo(i).Recess = 1
           Exit For
       End If
    Next
    sHolidayRecess = 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 sWeekDayStr() As String
   Select Case WeekDay(mvarDate)
     Case vbSunday
        sWeekDayStr = "星期日"
     Case vbMonday
        sWeekDayStr = "星期一"
     Case vbTuesday
        sWeekDayStr = "星期二"
     Case vbWednesday
        sWeekDayStr = "星期三"
     Case vbThursday
        sWeekDayStr = "星期四"
     Case vbFriday
        sWeekDayStr = "星期五"
     Case vbSaturday
        sWeekDayStr = "星期六"
   End Select
End Property

Public Function Constellation2(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/2000# 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 #12/31/2000#
            ConstellName = "阴性、土象星座，守护行星：土星"
      Case #1/1/2000# To #1/19/2000#
            ConstellName = "阴性、土象星座，守护行星：土星"
      Case #1/20/2000# To #2/18/2000#
            ConstellName = "阳性、风象星座,守护行星：天王星(传统上为土星)"
      Case #2/19/2000# To #3/20/2000#
            ConstellName = "阴性、水象星座，守护行星：海王星"
      Case Else
            ConstellName = ""
   End Select
   Constellation2 = ConstellName
End Function

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 = "亿"