cls_date.cls

实现的日历的动态查询,以及详细的日期信息.

            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, vbMonday)
    
'    Debug.Print "mvarDate="; mvarDate
End Property

'计算星期几中文字串
Public Property Get sWeekDayStr() As String
   Select Case WeekDay(mvarDate)
    
'    Debug.Print "mvarDate="; 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 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
Public 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 = "九"
        Case 10
          Converts = "十"
        Case 11
          Converts = "十一"
        Case 12
          Converts = "十二"
        Case 13
          Converts = "十三"
        Case 14
          Converts = "十四"