clsdate.cls

VB精美仿VISTA时钟

                   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/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
   Constellation = ConstellName
End Function
'/////////////////////////////////////////////////////////////////////////////////////////////////////////
'以下为类内部使用的一些函数
'传回农历 y年的总天数
Private Function lYearDays(ByVal Y As Long) As Long
   
'   Dim i As Long
'   Dim f As Long
'   Dim sumDay As Long
'   Dim info As Long
   
'   sumDay = 348
'   i = &H8000
'   info = LunarInfo(y - 1900) And &H1000FFFF  '屏蔽高位,
'   Do
'     f = info And i
'     If f <> 0 Then
'       sumDay = sumDay + 1
'     End If
'     i = BitRight16(i, 1)
'   Loop Until i < &H10
'   lYearDays = sumDay + leapDays(y)
    
    lYearDays = LunarYearDays(Y - 1900)  '先计算出每年的天数,并形成数组,以减少以后的运算时间
End Function

'传回农历 y年m月的总天数
Private Function lMonthDays(ByVal Y As Long, ByVal m As Long) As Long
  'If (LunarInfo(y - 1900) And &H1000FFFF) And BitRight32(&H10000, m) Then
  
  If mvarBitTest32((LunarInfo(Y - 1900) And &H1000FFFF), 16 - m) Then
     lMonthDays = 30
  Else
     lMonthDays = 29
  End If
End Function

'传回农历 y年闰月的天数
Private Function leapDays(Y As Long) As Long
  If leapMonth(Y) Then
    If LunarInfo(Y - 1900) And &H10000 Then
      leapDays = 30
    Else
      leapDays = 29
    End If
  Else
    leapDays = 0
  End If
End Function

'传回农历 y年闰哪个月 1-12 , 没闰传回 0
Private Function leapMonth(Y As Long) As Long
  Dim i As Long
  i = LunarInfo(Y - 1900) And &HF
  If i > 12 Then
    Debug.Print Y
  End If
  leapMonth = i
End Function

'计算公历年月的天数
Private Function SolarDays(Y As Long, m As Long) As Long
   Dim d As Long
   
   If (Y Mod 4) = 0 Then   '闰年
      If m = 2 Then
        d = 29
      Else
        d = SolarMonth(m - 1)
      End If
   Else
      If m = 2 Then
        d = 28
      Else
        d = SolarMonth(m - 1)
      End If
   End If
   
   SolarDays = d
End Function


'//////////////////////////////////////////////////////////////////////////////////////////////////
'
'主要的函数,用公历年月日对日期对象进行初使化,在此函数内部完成对私有对象属性的设置
'
'//////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub sInitDate(ByVal Y As Long, ByVal m As Long, ByVal d As Long)
    Dim i As Long
    Dim leap As Long
    Dim temp As Long
    Dim offset As Long
    
    mvarDate = DateSerial(Y, m, d)
    mvarsYear = Y
    mvarsMonth = m
    mvarsDay = d
    
    '农历日期计算部分
    leap = 0
    temp = 0
    
    offset = mvarDate - #1/30/1900#  '计算两天的基本差距
    
    For i = 1900 To 2049
        temp = lYearDays(i)  '求当年农历年天数
        
        offset = offset - temp
        If offset < 1 Then Exit For
    Next
    
    offset = offset + temp
    mvarlYear = i
    
    leap = leapMonth(i) '闰哪个月
    
    mvarIsLeap = False
    For i = 1 To 12
        '闰月
        If leap > 0 And i = (leap + 1) And mvarIsLeap = False Then
           mvarIsLeap = True
           i = i - 1
           temp = leapDays(mvarlYear)   '计算闰月天数
        Else
           mvarIsLeap = False
           temp = lMonthDays(mvarlYear, i) '计算非闰月天数
        End If
    
        offset = offset - temp
        If offset <= 0 Then Exit For
    Next
    
    offset = offset + temp
    mvarlMonth = i
    mvarlDay = offset
        
End Sub

'//////////////////////////////////////////////////////////////////////////////////////////////////
'
'主要的函数,用农历年月日对日期对象进行初使化,在此函数内部完成对私有对象属性的设置
'
'//////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub lInitDate(ByVal Y As Long, ByVal m As Long, ByVal d As Long, Optional LeapFlag As Boolean = False)
    Dim i As Long
    Dim leap As Long
    Dim temp As Long
    Dim offset As Long

    mvarlYear = Y
    mvarlMonth = m
    mvarlDay = d
    
    offset = 0
    
    For i = 1900 To Y - 1
       temp = LunarYearDays(i - 1900) '求当年农历年天数
       offset = offset + temp
    Next
    
    leap = leapMonth(Y) '闰哪个月
    If m <> leap Then
       mvarIsLeap = False  '当前日期并非闰月
    Else
       mvarIsLeap = LeapFlag  '使用用户输入的是否闰月月份
    End If
    
    If (m < leap) Or (leap = 0) Then   '当闰月在当前日期后
        For i = 1 To m - 1
           temp = lMonthDays(Y, i) '计算非闰月天数
           offset = offset + temp
        Next
    Else   '在闰月后
        If mvarIsLeap = False Then  '用户要计算非闰月的月份
             For i = 1 To m - 1
                temp = lMonthDays(Y, i) '计算非闰月天数
                offset = offset + temp
             Next
             If m > leap Then
                temp = leapDays(Y)   '计算闰月天数
                offset = offset + temp
             End If
             
        Else  '此时只有mvarisleap=ture,
               For i = 1 To m
                 temp = lMonthDays(Y, i) '计算非闰月天数
                 offset = offset + temp
               Next
        End If
    End If
    
    offset = offset + d '加上当月的天数
    mvarDate = DateAdd("d", offset, #1/30/1900#)
    mvarsYear = Year(mvarDate)
    mvarsMonth = Month(mvarDate)
    mvarsDay = Day(mvarDate)

End Sub

'本模块用于打印出1900-2049年 每年农历的天数,可以用于数组初使化
'Public Sub printf()
'    Dim i As Long, j As Long
'    Dim temp(10) As Long
'    Dim base As Long
'
'    base = 1900
'    For i = 1 To 15
'       For j = 1 To 10
'         temp(j - 1) = lYearDays((i - 1) * 10 + (j - 1) + base) '求当年农历年天数
'       Next
'       Debug.Print CStr(temp(0)) & " , " & CStr(temp(1)) & " , " & CStr(temp(2)) & " , " & CStr(temp(3)) & " , " & CStr(temp(4)) & " , " & CStr(temp(5)) & " , " & CStr(temp(6)) & " , " & CStr(temp(7)) & " , " & CStr(temp(8)) & " , " & CStr(temp(9)) & " , " & " _ "
'    Next
'End Sub