網(wǎng)上流傳很多計(jì)算公農(nóng)歷的源代碼，很多，但是居然沒有VB的，暈，
所以。。。。。

用法：
以l開始的方法均為陰歷，以s開始的方法均為公歷
基本的兩個初使函數(shù)：
lInitDate：用農(nóng)歷年月日初使化日期對象
sInitDate: 用公歷年月日初使化日期對象

其它的方法看下面的一小段代碼吧
示例代碼
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 1900, 1, 1
t.lInitDate 2047, 5, 12, False '農(nóng)歷2047年5月12日，非閏月
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) '農(nóng)歷日期中文大寫
Debug.Print t.GanZhi(t.lYear) '求干支
Debug.Print t.YearAttribute(t.lYear) '農(nóng)歷年的屬相
Debug.Print t.sYear ' 公歷年
Debug.Print t.sMonth ' 公歷月
Debug.Print t.sDay ' 公歷日
Debug.Print t.sWeekDay '公歷星期
Debug.Print t.Era(t.sYear)' 公歷紀(jì)元
Debug.Print t.Constellation(t.sMonth, t.sDay) ' 星座
Debug.Print "Week:" & t.wHoliday ' 按第幾個星期幾計(jì)算的假日
Debug.Print "Solar" & t.sHoliday ' 按公歷計(jì)算的假日
Debug.Print "Lunar" & t.lHoliday ' 按陰歷計(jì)算的假日
Debug.Print t.lSolarTerm ' 計(jì)算節(jié)氣

'以下為速度測試，很快吧。
st = Timer
With t
For y = 1900 To 2049
For m = 1 To 12
For d = 1 To 28
.lInitDate y, m, d, False

Next
Next
Next
End With
't.printf
et = Timer
Debug.Print et - st
Set t = Nothing
End Sub

以下為代碼:


Option Explicit
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 '局部復(fù)制
Private mvarsMonth As Long '局部復(fù)制
Private mvarsDay As Long '局部復(fù)制
Private mvarlYear As Long '局部復(fù)制
Private mvarlMonth As Long '局部復(fù)制
Private mvarlDay As Long '局部復(fù)制
Private mvarIsLeap As Boolean '局部復(fù)制
Private Declare Function BitRight32 Lib "Bit4VB.DLL" (ByVal x As Long, ByVal num As Long) As Long
'Private Declare Function BitRight16 Lib "Bit4VB.DLL" (ByVal x As Integer, ByVal num As Integer) As Integer
'定義類內(nèi)部用公用變量
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 '內(nèi)部使用標(biāo)準(zhǔn)的日期變量

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
'根據(jù)VB的位計(jì)算特點(diǎn),故擴(kuò)充原有的數(shù)據(jù)位,將其變成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")

'國歷節(jié)日 *表示放假日
sFtv = Array( _
1, 1, 1, "元旦", _
2, 14, 0, "情人節(jié)", 2, 10, 0, "國際氣象節(jié)", _
3, 18, 0, "婦女節(jié)", 3, 12, 0, "植樹節(jié)", 3, 15, 0, "消費(fèi)者權(quán)益日", _
4, 1, 0, "愚人節(jié)", _
5, 1, 1, "勞動節(jié)", 5, 4, 0, "青年節(jié)", 5, 12, 0, "護(hù)士節(jié)", 5, 31, 0, "世界無煙日", _
6, 1, 0, "兒童節(jié)", _
7, 1, 0, "建黨節(jié) 香港回歸紀(jì)念", _
8, 1, 0, "建軍節(jié)", 8, 8, 0, "中國男子節(jié) 父親節(jié)", _
9, 9, 0, "毛澤東逝世紀(jì)念", 9, 10, 0, "教師節(jié)", 9, 18, 0, "九·一八事變紀(jì)念日", 9, 28, 0, "孔子誕辰", _
10, 1, 0, "國慶節(jié) 國際音樂日", 10, 6, 0, "老人節(jié)", 10, 24, 0, "聯(lián)合國日", _
11, 12, 0, "孫中山誕辰紀(jì)念", _
12, 1, 0, "世界艾滋病日", 12, 3, 0, "世界殘疾人日", 12, 20, 0, "澳門回歸紀(jì)念", 12, 24, 0, "平安夜", 12, 25, 0, "圣誕節(jié)", 12, 26, 0, "毛澤東誕辰紀(jì)念")

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

'農(nóng)歷節(jié)日 *表示放假日
lFtv = Array( _
1, 1, 1, "春節(jié)", _
1, 15, 0, "元宵節(jié)", _
5, 5, 0, "端午節(jié)", _
7, 7, 0, "七夕情人節(jié)", _
7, 15, 0, "中元節(jié) 盂蘭盆節(jié)", _
8, 15, 0, "中秋節(jié)", _
9, 9, 0, "重陽節(jié)", _
12, 8, 0, "臘八節(jié)", _
12, 24, 0, "小年")
'12, 31, 0, "除夕") '注意除夕需要其它方法進(jìn)行計(jì)算

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, "國際母親節(jié)", _
5, 3, 1, "全國助殘日", _
6, 3, 1, "父親節(jié)", _
9, 3, 3, "國際和平日", _
9, 4, 1, "國際聾人節(jié)", _
10, 1, 2, "國際住房日", _
10, 1, 4, "國際減輕自然災(zāi)害日", _
11, 4, 5, "感恩節(jié)")
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
End Sub
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////
'計(jì)算農(nóng)歷上的節(jié)氣
Public Property Get lSolarTerm() As String
'//===== 某年的第n個節(jié)氣為幾日(從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())
'//節(jié)氣
' 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) '按分鐘計(jì)算,之所以不按秒鐘計(jì)算，是因?yàn)闀�溢�?
If Abs(DateDiff("d", newDate, mvarDate)) = 0 Then
tempStr = SolarTerm(i - 1)
Exit For
End If
Next

lSolarTerm = tempStr
End Property
'計(jì)算按第幾周星期幾計(jì)算的節(jié)日
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 '當(dāng)月份相當(dāng)時
w = WeekDay(mvarDate)
If wHolidayInfo(i).WeekDay = w Then '僅當(dāng)星期幾也相等時
FirstDay = mvarsMonth & "/" & 1 & "/" & mvarsYear '取當(dāng)月第一天
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 '保存農(nóng)歷年數(shù)
odate = mvarDate
ndate = mvarDate + 1
Call sInitDate(Year(ndate), Month(ndate), Day(ndate)) '計(jì)算第二天的屬性
If oy = mvarlYear - 1 Then '如果農(nóng)歷年數(shù)增加了1
tempStr = "除夕"
Call sInitDate(Year(odate), Month(odate), Day(odate)) '恢復(fù)到今天原有數(shù)據(jù)

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
'求公歷節(jié)日
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
'是否是農(nóng)歷的閏月
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 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

'根據(jù)年份不同計(jì)算當(dāng)年屬于什么朝代
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 = "清朝宣統(tǒng)"
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 '計(jì)算干支
tempStr = Gan(i Mod 10) & Zhi(i Mod 12)
GanZhi = tempStr
End Function
'計(jì)算年的屬相字串
Public Function YearAttribute(y As Long) As String
YearAttribute = Animals((y - 1900) Mod 12)
End Function
'將數(shù)字漢化
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) '整數(shù)除法
s = s & nStr1(d Mod 10)
End Select
CDayStr = s
End Function
'計(jì)算星座歸屬
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/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
'/////////////////////////////////////////////////////////////////////////////////////////////////////////
'以下為類內(nèi)部使用的一些函數(shù)
'傳回農(nóng)歷 y年的總天數(shù)
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) '先計(jì)算出每年的天數(shù),并形成數(shù)組,以減少以后的運(yùn)算時間
End Function
'傳回農(nóng)歷 y年m月的總天數(shù)
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
'傳回農(nóng)歷 y年閏月的天數(shù)
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
'傳回農(nóng)歷 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
'計(jì)算公歷年月的天數(shù)
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

'//////////////////////////////////////////////////////////////////////////////////////////////////
'
'主要的函數(shù),用公歷年月日對日期對象進(jìn)行初使化,在此函數(shù)內(nèi)部完成對私有對象屬性的設(shè)置
'
'//////////////////////////////////////////////////////////////////////////////////////////////////
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

'農(nóng)歷日期計(jì)算部分
leap = 0
Temp = 0

offset = mvarDate - #1/30/1900# '計(jì)算兩天的基本差距

For i = 1900 To 2049
'temp = lYearDays(i) '求當(dāng)年農(nóng)歷年天數(shù)

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) '計(jì)算閏月天數(shù)
Else
Temp = lMonthDays(mvarlYear, i) '計(jì)算非閏月天數(shù)
End If

offset = offset - Temp
If offset <= 0 Then Exit For
Next

offset = offset + Temp
mvarlMonth = i
mvarlDay = offset

End Sub
'//////////////////////////////////////////////////////////////////////////////////////////////////
'
'主要的函數(shù),用農(nóng)歷年月日對日期對象進(jìn)行初使化,在此函數(shù)內(nèi)部完成對私有對象屬性的設(shè)置
'
'//////////////////////////////////////////////////////////////////////////////////////////////////
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) '求當(dāng)年農(nóng)歷年天數(shù)
offset = offset + Temp
Next

leap = leapMonth(y) '閏哪個月
If m <> leap Then
mvarIsLeap = False '當(dāng)前日期并非閏月
Else
mvarIsLeap = LeapFlag '使用用戶輸入的是否閏月月份
End If

If (m < leap) Or (leap = 0) Then '當(dāng)閏月在當(dāng)前日期后
For i = 1 To m - 1
Temp = lMonthDays(y, i) '計(jì)算非閏月天數(shù)
offset = offset + Temp
Next
Else '在閏月后
If mvarIsLeap = False Then '用戶要計(jì)算非閏月的月份
For i = 1 To m - 1
Temp = lMonthDays(y, i) '計(jì)算非閏月天數(shù)
offset = offset + Temp
Next
If m > leap Then
Temp = leapDays(y) '計(jì)算閏月天數(shù)
offset = offset + Temp
End If

Else '此時只有mvarisleap=ture,
For i = 1 To m
Temp = lMonthDays(y, i) '計(jì)算非閏月天數(shù)
offset = offset + Temp
Next
End If
End If

offset = offset + d '加上當(dāng)月的天數(shù)
mvarDate = DateAdd("d", offset, #1/30/1900#)
mvarsYear = Year(mvarDate)
mvarsMonth = Month(mvarDate)
mvarsDay = Day(mvarDate)
End Sub
'本模塊用于打印出1900-2049年 每年農(nóng)歷的天數(shù),可以用于數(shù)組初使化
'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) '求當(dāng)年農(nóng)歷年天數(shù)
' 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