********************************************************************************************
'建一個類，類名爲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來支持這個類了。
'
注 意 事 項
'
' ///////////////////////////////////////////////////////////////////////////////
' // //
' // //
' // 說明:本模塊僅能用於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
建一個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