y = 2000 tempDate = m & "/" & d & "/" & y Select Case tempDate Case #3/21/2003# 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 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 = m & "/" & d & "/" & y 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 Temp = lMonthDays(mvarlYear, i) ''''计算非闰月天数 End If
offset = offset - Temp If offset <= 0 Then Exit For Next
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