阴阳历的算法‘*********************************‘定义变量‘*********************************Public LunarInfo(1 To 150) As Double '从1900-2049年这150年的农历信息码Public SolarMonth(1 To 12) As Integer '阳历12个月的天数Public Gan(1 To 10) As String '农历的天干Public Zhi(1 To 12) As String '农历的地支Public Animals(1 To 12) As String '农历的属象Public SolarTerm(1 To 24) As String '阳历的节气Public sTermInfo(1 To 24) As Double '阳历节气的信息码Public nStr1(1 To 11) As String '从日一到十Public nStr2(1 To 5) As String '初十廿卅 'Public MonthName(1 To 12) As String '每个月的英文名称Public sFtv(1 To 30) As String '阳历的节日Public lFtv(1 To 30) As String '农历的节日Public wFtv(1 To 30) As String '西方的节日
‘*********************‘赋值：略‘*********************LunarInfo（1 to 150）：0x04bd8,0x04ae0,0x0a570,0x054d5,0x0d260,0x0d950,0x16554,0x056a0,0x09ad0,0x055d2,0x04ae0,0x0a5b6,0x0a4d0,0x0d250,0x1d255,0x0b540,0x0d6a0,0x0ada2,0x095b0,0x14977,0x04970,0x0a4b0,0x0b4b5,0x06a50,0x06d40,0x1ab54,0x02b60,0x09570,0x052f2,0x04970,0x06566,0x0d4a0,0x0ea50,0x06e95,0x05ad0,0x02b60,0x186e3,0x092e0,0x1c8d7,0x0c950,0x0d4a0,0x1d8a6,0x0b550,0x056a0,0x1a5b4,0x025d0,0x092d0,0x0d2b2,0x0a950,0x0b557,0x06ca0,0x0b550,0x15355,0x04da0,0x0a5d0,0x14573,0x052d0,0x0a9a8,0x0e950,0x06aa0,0x0aea6,0x0ab50,0x04b60,0x0aae4,0x0a570,0x05260,0x0f263,0x0d950,0x05b57,0x056a0,0x096d0,0x04dd5,0x04ad0,0x0a4d0,0x0d4d4,0x0d250,0x0d558,0x0b540,0x0b5a0,0x195a6,0x095b0,0x049b0,0x0a974,0x0a4b0,0x0b27a,0x06a50,0x06d40,0x0af46,0x0ab60,0x09570,0x04af5,0x04970,0x064b0,0x074a3,0x0ea50,0x06b58,0x055c0,0x0ab60,0x096d5,0x092e0,0x0c960,0x0d954,0x0d4a0,0x0da50,0x07552,0x056a0,0x0abb7,0x025d0,0x092d0,0x0cab5,0x0a950,0x0b4a0,0x0baa4,0x0ad50,0x055d9,0x04ba0,0x0a5b0,0x15176,0x052b0,0x0a930,0x07954,0x06aa0,0x0ad50,0x05b52,0x04b60,0x0a6e6,0x0a4e0,0x0d260,0x0ea65,0x0d530,0x05aa0,0x076a3,0x096d0,0x04bd7,0x04ad0,0x0a4d0,0x1d0b6,0x0d250,0x0d520,0x0dd45,0x0b5a0,0x056d0,0x055b2,0x049b0,0x0a577,0x0a4b0,0x0aa50,0x1b255,0x06d20,0x0ada0For i = 1 To 12 Select Case i Case 1, 3, 5, 7, 8, 10, 12 SolarMonth(i) = 31 Case 2 SolarMonth(i) = 28 Case Else SolarMonth(i) = 30 End SelectNext iDim s1, s2, s3, s4, s5, s6, s7, s8 As String s1 = "甲乙丙丁戊己庚辛壬癸" s2 = "子丑寅卯辰巳午未申酉戌亥" s3 = "鼠牛虎兔龙蛇马羊猴鸡狗猪" s4 = "小寒大寒立春雨水惊蛰春分清明谷雨立夏小满芒种夏至小暑大暑立秋处暑白露秋分寒露霜降立冬小雪大雪冬至" s5 = "000000,021208,042467,063836,085337,107014,128867,150921,173149,195551,218072,240693,263343,285989,308563,331033,353350,375494,397447,419210,440795,462224,483532,504758" s6 = "日一二三四五六七八九十" s7 = "初十廿卅 " s8 = "JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC"For i = 1 To 24 If i <= 10 Then Gan(i) = Mid(s1, i, 1) If i <= 12 Then Zhi(i) = Mid(s2, i, 1) Animals(i) = Mid(s3, i, 1) End If SolarTerm(i) = Mid(s4, (i - 1) * 2 + 1, 2) sTermInfo(i) = Val(Mid(s5, (i - 1) * 7 + 1, 6)) If i <= 11 Then nStr1(i) = Mid(s6, i, 1) If i <= 5 Then nStr2(i) = Mid(s7, i, 1) If i <= 12 Then MonthName(i) = Mid(s8, (i - 1) * 4 + 1, 3) Next i‘阳历节日：前四位数字为阳历的MMDD（月日），后面的文字为意义 sFtv(1) = "0101*元旦" sFtv(2) = "0214情人节" sFtv(3) = "0308妇女节" sFtv(4) = "0312植树节" sFtv(5) = "0315权益日" sFtv(6) = "" sFtv(7) = "0401愚人节" sFtv(8) = "0501*劳动节" sFtv(9) = "0504青年节" sFtv(10) = "0512护士节" sFtv(11) = "0601儿童节" sFtv(12) = "0701建党节" sFtv(13) = "0718托普诞辰" sFtv(14) = "0801建军节" sFtv(15) = "0808父亲节" sFtv(16) = "0909毛逝世纪念" sFtv(17) = "0910教师节" sFtv(18) = "0928孔子诞辰" sFtv(19) = "1001*国庆节" sFtv(20) = "1006老人节" sFtv(21) = "1024联合国日" sFtv(22) = "1112孙中山诞辰" sFtv(23) = "1220澳门回归" sFtv(24) = "1225圣诞节" sFtv(25) = "1226毛诞辰纪念"
‘农历的节日：日期表示的是农历的某月某日 lFtv(1) = "0101*春节" lFtv(2) = "0115元宵节" IFtv(3) = "0505端午节" lFtv(4) = "0707七夕节" lFtv(5) = "0715中元节" lFtv(6) = "0815中秋节" lFtv(7) = "0909重阳节" lFtv(8) = "" lFtv(9) = "1208腊八节" lFtv(10) = "1224小年" lFtv(11) = "0100*除夕"
‘按星期计算的节日：如0231表示阳历02月份的第三个星期一 wFtv(1) = "" wFtv(2) = "0231总统日" WFtv(3) = "0520母亲节" wFtv(4) = "" wFtv(5) = "0531胜利日" wFtv(6) = "0716合作节" wFtv(7) = "0730被奴周" wFtv(8) = "" wFtv(9) = "" wFtv(10) = "1021哥伦布日" wFtv(11) = "1144感恩节"
‘**************************************‘日历系统中的常用处理函数‘**************************************'传回农历 y年m月的总天数Function lMonthDays(ByVal Y As Integer, ByVal m As Integer) As Integer If Y < 1900 Then Y = 1900 If (LunarInfo(Y - 1900 + 1) And Int(&H10000 / (2 ^ m))) = 0 Then lMonthDays = 29 Else lMonthDays = 30 End IfEnd Function'传回农历 y年闰哪个月 1-12 , 没闰传回 0Function LeapMonth(ByVal Y As Integer) As Integer LeapMonth = 0 If Y >= 1900 Then LeapMonth = (LunarInfo(Y - 1900 + 1) And &HF)End Function'传回农历 y年闰月的天数Function LeapDays(ByVal Y As Integer) As Integer Dim m As Integer Dim l As Double m = LeapMonth(Y) If m = 0 Then LeapDays = 0 Else l = LunarInfo(Y - 1900 + 1) If l < 0 Then l = l * (-1) l = (l And &H10000) If l = 0 Then LeapDays = 29 Else LeapDays = 30 End If End IfEnd Function'传回农历 y年的总天数Function lYearDays(ByVal Y As Integer) As Integer Dim i, Sum As Double Sum = 0 For i = 1 To 12 Sum = Sum + lMonthDays(Y, i) Next i lYearDays = Sum + LeapDays(Y)End Function'传回阳历 y年某m月的天数Function SolarDays(ByVal Y As Integer, ByVal m As Integer) As Integer If m = 2 Then If (Y Mod 4 = 0 And Y Mod 100 <> 0) Or (Y Mod 400 = 0) Then SolarDays = 29 Else SolarDays = 28 End If Else SolarDays = SolarMonth(m) End IfEnd Function'根据年份返回属象Function Animal(ByVal sYear As Integer) As String Animal = Animals((sYear - 1900) Mod 12 + 1) End Function
'根据给定的阳历，返回农历的日期Function GetLunar(ByVal SolarDate As Date) As String Dim DaysOffset As Long Dim i As Integer Dim Temp As Long Dim lyear, lmonth, lday As Integer DaysOffset = SolarDate - CDate("1900-1-31") i = 1900 Do While i < 2050 And DaysOffset >= 0 Temp = lYearDays(i) DaysOffset = DaysOffset - Temp i = i + 1 Loop If DaysOffset < 0 Then DaysOffset = DaysOffset + Temp i = i - 1 End If lyear = i Dim Leap As Integer Dim IsLeap As Boolean Leap = LeapMonth(i) IsLeap = False i = 1 Do While i < 13 And DaysOffset > 0 If Leap > 0 And i = (Leap + 1) And IsLeap = False Then i = i - 1 IsLeap = True Temp = LeapDays(lyear) Else Temp = lMonthDays(lyear, i) End If If IsLeap And i = (Leap + 1) Then IsLeap = False DaysOffset = DaysOffset - Temp i = i + 1 Loop If DaysOffset = 0 And Leap > 0 And i = Leap + 1 Then If IsLeap Then IsLeap = False Else IsLeap = True i = i - 1 End If End If If DaysOffset < 0 Then DaysOffset = DaysOffset + Temp i = i - 1 End If lmonth = i lday = DaysOffset + 1'返回特殊标志的字符串 If IsLeap Then 'GetLunar = "0000【" & Animal(lYear) & "】" & GanZhi(lYear) & "年闰" & Format(lMonth, "00") & "月" & Format(lDay, "00") & "日" & GetTerm(SolarDate) GetLunar = "1" & lyear & Format(lmonth, "00") & Format(lday, "00") Else GetLunar = "0" & lyear & Format(lmonth, "00") & Format(lday, "00") 'GetLunar = Format(lMonth, "00") & Format(lDay, "00") & "【" & Animal(lYear) & "】" & GanZhi(lYear) & "年" & Format(lMonth, "00") & "月" & Format(lDay, "00") & "日 " & GetTerm(SolarDate) End IfEnd Function'某y年的第n个节气的日期(从1小寒起算)Function sTerm(ByVal Y, n As Integer) As Date Dim D1, D2 As Double D1 = (31556925.9747 * (Y - 1900) + sTermInfo(n) * 60#) D2 = DateDiff("s", "1970-1-1 0:0", "1900-1-6 2:5") + D1 D1 = D2 / 2 sTerm = DateAdd("s", D2 - D1, DateAdd("s", D1, "1970-1-1 0:0")) sTerm = Format(sTerm, "yyyy/mm/dd")End Function'根据阳历返回其节气，若不是则返回空Function GetTerm(ByVal sDate As Date) As String Dim Y, m As Integer Y = Year(sDate) m = Month(sDate) GetTerm = " " If sTerm(Y, m * 2 - 1) = sDate Then GetTerm = SolarTerm(m * 2 - 1) ElseIf sTerm(Y, m * 2) = sDate Then GetTerm = SolarTerm(m * 2) End IfEnd Function'返回阳历是该月的第几个星期几的字符串，如:0520表示5月份第2个星期日Function GetMonthWeek(ByVal sDate As Date) As String Dim D0 As Date D0 = CDate(Year(sDate) & "-" & Month(sDate) & "-1") GetMonthWeek = Format(Month(sDate), "00") & (Int((Day(sDate) - 1 + Weekday(D0) - 1) / 7) + 1) & Weekday(sDate) - 1End Function
