1900-2090 的农历算法 (VB)

Option Explicit

Public LunarInfo(1 To 191) As Double '从1900-2090年这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 17) As String '阳历的节日
Public lFtv(1 To 10) As String '农历的节日
'Public wFtv(1 To 30) As String '西方的节日

Public Sub SetValue()
  Dim i As Integer
 
  '阳历节日：前四位数字为阳历的MMDD（月日），后面的文字为意义
  sFtv(1) = "0101元旦"
  sFtv(2) = "0214情人节"
  sFtv(3) = "0308妇女节"
  sFtv(4) = "0312植树节"
  sFtv(5) = "0315权益日"
  sFtv(6) = "0401愚人节"
  sFtv(7) = "0501劳动节"
  sFtv(8) = "0504青年节"
  sFtv(9) = "0512护士节"
  sFtv(10) = "0601儿童节"
  sFtv(11) = "0701建党节"
  sFtv(12) = "0801建军节"
  sFtv(13) = "0808父亲节"
  sFtv(14) = "0910教师节"
  sFtv(15) = "1001国庆节"
  sFtv(16) = "1006老人节"
  sFtv(17) = "1225圣诞节"

  '农历的节日：日期表示的是农历的某月某日
 
  lFtv(1) = "0101春节"
  lFtv(2) = "0115元宵节"
  lFtv(3) = "0505端午节"
  lFtv(4) = "0707七夕节"
  lFtv(5) = "0715中元节"
  lFtv(6) = "0815中秋节"
  lFtv(7) = "0909重阳节"
  lFtv(8) = "1208腊八节"
  lFtv(9) = "1224小年"
  lFtv(10) = "0100除夕"
 
  '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感恩节"

'********************

  LunarInfo(1) = &H4BD8
  LunarInfo(2) = &H4AE0
  LunarInfo(3) = &HA570
  LunarInfo(4) = &H54D5
  LunarInfo(5) = &HD260
  LunarInfo(6) = &HD950
  LunarInfo(7) = &H16554
  LunarInfo(8) = &H56A0
  LunarInfo(9) = &H9AD0
  LunarInfo(10) = &H55D2
  LunarInfo(11) = &H4AE0
  LunarInfo(12) = &HA5B6
  LunarInfo(13) = &HA4D0
  LunarInfo(14) = &HD250
  LunarInfo(15) = &H1D255
  LunarInfo(16) = &HB540
  LunarInfo(17) = &HD6A0
  LunarInfo(18) = &HADA2
  LunarInfo(19) = &H95B0
  LunarInfo(20) = &H14977
  LunarInfo(21) = &H4970
  LunarInfo(22) = &HA4B0
  LunarInfo(23) = &HB4B5
  LunarInfo(24) = &H6A50
  LunarInfo(25) = &H6D40
  LunarInfo(26) = &H1AB54
  LunarInfo(27) = &H2B60
  LunarInfo(28) = &H9570
  LunarInfo(29) = &H52F2
  LunarInfo(30) = &H4970
  LunarInfo(31) = &H6566
  LunarInfo(32) = &HD4A0
  LunarInfo(33) = &HEA50
  LunarInfo(34) = &H6E95
  LunarInfo(35) = &H5AD0
  LunarInfo(36) = &H2B60
  LunarInfo(37) = &H186E3
  LunarInfo(38) = &H92E0
  LunarInfo(39) = &H1C8D7
  LunarInfo(40) = &HC950
  LunarInfo(41) = &HD4A0
  LunarInfo(42) = &H1D8A6
  LunarInfo(43) = &HB550
  LunarInfo(44) = &H56A0
  LunarInfo(45) = &H1A5B4
  LunarInfo(46) = &H25D0
  LunarInfo(47) = &H92D0
  LunarInfo(48) = &HD2B2
  LunarInfo(49) = &HA950
  LunarInfo(50) = &HB557
  LunarInfo(51) = &H6CA0
  LunarInfo(52) = &HB550
  LunarInfo(53) = &H15355
  LunarInfo(54) = &H4DA0
  LunarInfo(55) = &HA5D0
  LunarInfo(56) = &H14573
  LunarInfo(57) = &H52D0
  LunarInfo(58) = &HA9A8
  LunarInfo(59) = &HE950
  LunarInfo(60) = &H6AA0
  LunarInfo(61) = &HAEA6
  LunarInfo(62) = &HAB50
  LunarInfo(63) = &H4B60
  LunarInfo(64) = &HAAE4
  LunarInfo(65) = &HA570
  LunarInfo(66) = &H5260
  LunarInfo(67) = &HF263
  LunarInfo(68) = &HD950
  LunarInfo(69) = &H5B57
  LunarInfo(70) = &H56A0
  LunarInfo(71) = &H96D0
  LunarInfo(72) = &H4DD5
  LunarInfo(73) = &H4AD0
  LunarInfo(74) = &HA4D0
  LunarInfo(75) = &HD4D4
  LunarInfo(76) = &HD250
  LunarInfo(77) = &HD558
  LunarInfo(78) = &HB540
  LunarInfo(79) = &HB5A0
  LunarInfo(80) = &H195A6
  LunarInfo(81) = &H95B0
  LunarInfo(82) = &H49B0
  LunarInfo(83) = &HA974
  LunarInfo(84) = &HA4B0
  LunarInfo(85) = &HB27A
  LunarInfo(86) = &H6A50
  LunarInfo(87) = &H6D40
  LunarInfo(88) = &HAF46
  LunarInfo(89) = &HAB60
  LunarInfo(90) = &H9570
  LunarInfo(91) = &H4AF5
  LunarInfo(92) = &H4970
  LunarInfo(93) = &H64B0
  LunarInfo(94) = &H74A3
  LunarInfo(95) = &HEA50
  LunarInfo(96) = &H6B58
  LunarInfo(97) = &H55C0
  LunarInfo(98) = &HAB60
  LunarInfo(99) = &H96D5
  LunarInfo(100) = &H92E0
  LunarInfo(101) = &HC960
  LunarInfo(102) = &HD954
  LunarInfo(103) = &HD4A0
  LunarInfo(104) = &HDA50
  LunarInfo(105) = &H7552
  LunarInfo(106) = &H56A0
  LunarInfo(107) = &HABB7
  LunarInfo(108) = &H25D0
  LunarInfo(109) = &H92D0
  LunarInfo(110) = &HCAB5
  LunarInfo(111) = &HA950
  LunarInfo(112) = &HB4A0
  LunarInfo(113) = &HBAA4
  LunarInfo(114) = &HAD50
  LunarInfo(115) = &H55D9
  LunarInfo(116) = &H4BA0
  LunarInfo(117) = &HA5B0
  LunarInfo(118) = &H15176
  LunarInfo(119) = &H52B0
  LunarInfo(120) = &HA930
  LunarInfo(121) = &H7954
  LunarInfo(122) = &H6AA0
  LunarInfo(123) = &HAD50
  LunarInfo(124) = &H5B52
  LunarInfo(125) = &H4B60
  LunarInfo(126) = &HA6E6
  LunarInfo(127) = &HA4E0
  LunarInfo(128) = &HD260
  LunarInfo(129) = &HEA65
  LunarInfo(130) = &HD530
  LunarInfo(131) = &H5AA0
  LunarInfo(132) = &H76A3
  LunarInfo(133) = &H96D0
  LunarInfo(134) = &H4BD7
  LunarInfo(135) = &H4AD0
  LunarInfo(136) = &HA4D0
  LunarInfo(137) = &H1D0B6
  LunarInfo(138) = &HD250
  LunarInfo(139) = &HD520
  LunarInfo(140) = &HDD45
  LunarInfo(141) = &HB5A0
  LunarInfo(142) = &H56D0
  LunarInfo(143) = &H55B2
  LunarInfo(144) = &H49B0
  LunarInfo(145) = &HA577
  LunarInfo(146) = &HA4B0
  LunarInfo(147) = &HAA50
  LunarInfo(148) = &H1B255
  LunarInfo(149) = &H6D20
  LunarInfo(150) = &HADA0
   
  LunarInfo(151) = &H14B63
  LunarInfo(152) = &H9370
  LunarInfo(153) = &H49F8
  LunarInfo(154) = &H4970
  LunarInfo(155) = &H64B0
  LunarInfo(156) = &H168A6
  LunarInfo(157) = &HEA50
  LunarInfo(158) = &H6B20
  LunarInfo(159) = &H1A6C4
  LunarInfo(160) = &HAAE0
  LunarInfo(161) = &H92E0
  LunarInfo(162) = &HD2E3
  LunarInfo(163) = &HC960
  LunarInfo(164) = &HD557
  LunarInfo(165) = &HD4A0
  LunarInfo(166) = &HDA50
  LunarInfo(167) = &H5D55
  LunarInfo(168) = &H56A0
  LunarInfo(169) = &HA6D0
  LunarInfo(170) = &H55D4
  LunarInfo(171) = &H52D0
 
  LunarInfo(172) = &HA9B8
  LunarInfo(173) = &HA950
  LunarInfo(174) = &HB4A0
  LunarInfo(175) = &HB6A6
  LunarInfo(176) = &HAD50
  LunarInfo(177) = &H55A0
  LunarInfo(178) = &HABA4
  LunarInfo(179) = &HA5B0
  LunarInfo(180) = &H52B0
  LunarInfo(181) = &HB273
 
  LunarInfo(182) = &H6930
  LunarInfo(183) = &H7337
  LunarInfo(184) = &H6A60
  LunarInfo(185) = &HAD50
  LunarInfo(186) = &H6B55
  LunarInfo(187) = &H4B60
  LunarInfo(188) = &HA570
  LunarInfo(189) = &H54E4
  LunarInfo(190) = &HD160
  LunarInfo(191) = &HE968

 
  Dim s1, s2, s3, s4, s5, s6, s7 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 = "初十廿卅　"
 
  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)
  Next i

End Sub

'**************************************

'日历系统中的常用处理函数

'**************************************

'传回农历 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 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
 
  '/
  If SolarDate <= CDate("2000-2-5") Then
    DaysOffset = SolarDate - CDate("1900-1-31")
    i = 1900
    Do While i < 2001 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
  Else
    DaysOffset = SolarDate - CDate("2000-2-5")
    i = 2000
    Do While i < 2091 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
  End If
 
  '
 
  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 = "1" & Format(lyear, "0000") & Format(lmonth, "00") & Format(lday, "00")
  Else
    GetLunar = "0" & Format(lyear, "0000") & Format(lmonth, "00") & Format(lday, "00")
  End If
 
End Function

'将年份用天干地支表示
Public Function GanZhi(ByVal syear As Integer) As String
  Dim strGan, strZhi As String

  strGan = Gan((syear - 1900 + 6) Mod 10 + 1)
  strZhi = Zhi((syear - 1900 + 12) Mod 12 + 1)
  GanZhi = strGan + strZhi + "年"

End Function

'将月份用农历表示
Public Function CnMonth(ByVal smonth As Integer) As String

  If smonth < 10 Then
    CnMonth = nStr1(smonth) + "月"
  ElseIf smonth = 10 Then
    CnMonth = "十" + "月"
  Else
    CnMonth = "十" + nStr1(smonth Mod 10) + "月"
  End If
End Function

'将日用农历表示
Public Function CnDay(ByVal sday As Integer) As String
  If sday <= 10 Then
    CnDay = "初" + nStr1(sday)
  ElseIf sday < 20 Then
    CnDay = "十" + nStr1(sday Mod 10)
  ElseIf sday = 20 Then
    CnDay = "廿十"
  ElseIf sday < 30 Then
    CnDay = "廿" + nStr1(sday Mod 10)
  Else
    CnDay = "卅十"
  End If
End Function

'根据年份返回属象
Public Function Animal(ByVal syear As Integer) As String
  Animal = Animals((syear - 1900) Mod 12 + 1)
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

'根据阳历返回其节气，若不是则返回空
Public 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