阴阳历的算法(VB)

来源：互联网发布：java 解压文件编辑：程序博客网时间：2024/05/05 23:19

阴阳历的算法
‘*********************************
‘定义变量
‘*********************************
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 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 Select
Next i
Dim 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 If
End Function

'传回农历 y年闰哪个月 1-12 , 没闰传回 0
Function 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 If
End 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 If
End 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 If
End 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 If
End 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) - 1
End Function