我这有一个,你试试吧,好像功能多了点,你自己看着挑出来吧 ‘*********************************‘定义变量‘*********************************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,0x0ada0 For i = 1 To 12Select Case iCase 1, 3, 5, 7, 8, 10, 12SolarMonth(i) = 31Case 2SolarMonth(i) = 28Case ElseSolarMonth(i) = 30End SelectNext i Dim s1, s2, s3, s4, s5, s6, s7, s8 As Strings1 = "甲乙丙丁戊己庚辛壬癸"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 24If i <= 10 Then Gan(i) = Mid(s1, i, 1)If i <= 12 ThenZhi(i) = Mid(s2, i, 1)Animals(i) = Mid(s3, i, 1)End If
'根据给定的阳历，返回农历的日期Function GetLunar(ByVal SolarDate As Date) As StringDim DaysOffset As LongDim i As IntegerDim Temp As LongDim lyear, lmonth, lday As IntegerDaysOffset = SolarDate - CDate("1900-1-31")i = 1900Do While i < 2050 And DaysOffset >= 0Temp = lYearDays(i)DaysOffset = DaysOffset - Tempi = i + 1LoopIf DaysOffset < 0 ThenDaysOffset = DaysOffset + Tempi = i - 1End Iflyear = iDim Leap As IntegerDim IsLeap As BooleanLeap = LeapMonth(i)IsLeap = Falsei = 1Do While i < 13 And DaysOffset > 0If Leap > 0 And i = (Leap + 1) And IsLeap = False Theni = i - 1IsLeap = TrueTemp = LeapDays(lyear)ElseTemp = lMonthDays(lyear, i)End IfIf IsLeap And i = (Leap + 1) Then IsLeap = FalseDaysOffset = DaysOffset - Tempi = i + 1LoopIf DaysOffset = 0 And Leap > 0 And i = Leap + 1 ThenIf IsLeap ThenIsLeap = FalseElseIsLeap = Truei = i - 1End IfEnd IfIf DaysOffset < 0 ThenDaysOffset = DaysOffset + Tempi = i - 1End Iflmonth = ilday = 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")ElseGetLunar = "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 DateDim D1, D2 As DoubleD1 = (31556925.9747 * (Y - 1900) + sTermInfo(n) * 60#)D2 = DateDiff("s", "1970-1-1 0:0", "1900-1-6 2:5") + D1D1 = D2 / 2sTerm = 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 StringDim Y, m As IntegerY = Year(sDate)m = Month(sDate)GetTerm = " "If sTerm(Y, m * 2 - 1) = sDate ThenGetTerm = SolarTerm(m * 2 - 1)ElseIf sTerm(Y, m * 2) = sDate ThenGetTerm = SolarTerm(m * 2)End IfEnd Function '返回阳历是该月的第几个星期几的字符串，如:0520表示5月份第2个星期日Function GetMonthWeek(ByVal sDate As Date) As StringDim D0 As DateD0 = CDate(Year(sDate) & "-" & Month(sDate) & "-1")GetMonthWeek = Format(Month(sDate), "00") & (Int((Day(sDate) - 1 + Weekday(D0) - 1) / 7) + 1) & Weekday(sDate) - 1End Function
[email protected]
‘*********************************‘定义变量‘*********************************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,0x0ada0 For i = 1 To 12Select Case iCase 1, 3, 5, 7, 8, 10, 12SolarMonth(i) = 31Case 2SolarMonth(i) = 28Case ElseSolarMonth(i) = 30End SelectNext i
Dim s1, s2, s3, s4, s5, s6, s7, s8 As Strings1 = "甲乙丙丁戊己庚辛壬癸"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 24If i <= 10 Then Gan(i) = Mid(s1, i, 1)If i <= 12 ThenZhi(i) = Mid(s2, i, 1)Animals(i) = Mid(s3, i, 1)End If
'返回特殊标志的字符串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")ElseGetLunar = "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 DateDim D1, D2 As DoubleD1 = (31556925.9747 * (Y - 1900) + sTermInfo(n) * 60#)D2 = DateDiff("s", "1970-1-1 0:0", "1900-1-6 2:5") + D1D1 = D2 / 2sTerm = 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 StringDim Y, m As IntegerY = Year(sDate)m = Month(sDate)GetTerm = " "If sTerm(Y, m * 2 - 1) = sDate ThenGetTerm = SolarTerm(m * 2 - 1)ElseIf sTerm(Y, m * 2) = sDate ThenGetTerm = SolarTerm(m * 2)End IfEnd Function '返回阳历是该月的第几个星期几的字符串，如:0520表示5月份第2个星期日Function GetMonthWeek(ByVal sDate As Date) As StringDim D0 As DateD0 = CDate(Year(sDate) & "-" & Month(sDate) & "-1")GetMonthWeek = Format(Month(sDate), "00") & (Int((Day(sDate) - 1 + Weekday(D0) - 1) / 7) + 1) & Weekday(sDate) - 1End Function