分享
 
 
 

VB公农历1.02版,不需要任何DLL

王朝vb·作者佚名  2006-01-09
窄屏简体版  字體: |||超大  

'建一个Form1,然后添加一个CommandButton,贴上以下代码做测试。

Option Explicit

Private Sub Command1_Click()

Dim t As clsDate

Dim y As Long

Dim m As Long

Dim d As Long

Dim st As Single

Dim et As Single

Dim da As Date

Dim j As Long

Dim ret As Long

Set t = New clsDate

t.sInitDate 2004, 5, 18

't.lInitDate 2047, 5, 12, False

Debug.Print t.lYear

If t.IsLeap = False Then

Debug.Print t.lMonth

Else

Debug.Print " 闰 " & t.lMonth

End If

Debug.Print t.CDayStr(t.lDay)

Debug.Print t.GanZhi(t.lYear)

Debug.Print t.YearAttribute(t.lYear)

Debug.Print t.sYear

Debug.Print t.sMonth

Debug.Print t.sDay

Debug.Print t.sWeekDay

Debug.Print t.Era(t.sYear)

Debug.Print t.Constellation(t.sMonth, t.sDay)

Debug.Print "Week:" & t.wHoliday

Debug.Print "Solar" & t.sHoliday

Debug.Print "Lunar" & t.lHoliday

Debug.Print t.lSolarTerm

Set t = Nothing

End Sub

'********************************************************************************************

'建一个类,类名为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: liuxiaoshi@xtcz.net zhenghesoft@hotmail.com

'

'

' 版本预告:

' 下次我将推出 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, 14, 0, "情人节", 2, 10, 0, "国际气象节", _

3, 8, 0, "妇女节", 3, 12, 0, "植树节", 3, 15, 0, "消费者权益日", _

4, 1, 0, "愚人节", _

5, 1, 1, "劳动节", 5, 4, 0, "青年节", 5, 12, 0, "护士节", 5, 31, 0, "世界无烟日", _

6, 1, 0, "儿童节", _

7, 1, 0, "建党节 香港回归纪念", _

8, 1, 0, "建军节", 8, 8, 0, "中国男子节 父亲节", _

9, 9, 0, "毛泽东逝世纪念", 9, 10, 0, "教师节", 9, 18, 0, "九·一八事变纪念日", 9, 28, 0, "孔子诞辰", _

10, 1, 0, "国庆节 国际音乐日", 10, 6, 0, "老人节", 10, 24, 0, "联合国日", _

11, 12, 0, "孙中山诞辰纪念", _

12, 1, 0, "世界艾滋病日", 12, 3, 0, "世界残疾人日", 12, 20, 0, "澳门回归纪念", 12, 24, 0, "平安夜", 12, 25, 0, "圣诞节", 12, 26, 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, "元宵节", _

3, 13, 0, "公农历作者生日", _

5, 5, 0, "端午节", _

7, 7, 0, "七夕情人节", _

7, 15, 0, "中元节 盂兰盆节", _

8, 15, 0, "中秋节", _

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

Dim b As Long

Dim FirstDay As Date

Dim TempStr As String

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 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 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

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

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

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有