VB的农历算法(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

 

转载于:https://blog.51cto.com/vbcodeworkers/726624