转载-公历转换农历VB示例

Option Explicit
Private LunarInfo(1 To 150) As Double '从1900-2049年这150年的农历信息码
Private SolarMonth(1 To 12) As Integer '阳历12个月的天数
Private Gan(1 To 10) As String '农历的天干
Private Zhi(1 To 12) As String '农历的地支
Private Animals(1 To 12) As String '农历的属象
Private SolarTerm(1 To 24) As String '阳历的节气

Private sTermInfo(1 To 24) As Double '阳历节气的信息码
Private nStr1(1 To 11) As String '从日一到十
Private nStr2(1 To 5) As String '初十廿卅　'
Private MonthName(1 To 12) As String '每个月的英文名称

Private sFtv(1 To 30) As String '阳历的节日
Private lFtv(1 To 30) As String '农历的节日
Private wFtv(1 To 30) As String '西方的节日

Dim WeekName(7), MonthAdd(11), NongliData(99), TianGan(9), DiZhi(11), ShuXiang(11), DayName(30), MonName(12)
Dim curtime, curYear, curMonth, curDay, curWeekday
Dim GongliStr, WeekdayStr, NongliStr, NongliDayStr
Dim i, m, n, k, isEnd, bit, TheDate
Dim settime As Date
'--将农历信息从16进制转换成10进制
Public Function c16to10(shuju As String)
Dim s  As String
Dim d  As Integer
Dim da As Long

For i = 3 To 7
s = Mid(shuju, i, 1)

Select Case i

Case 3

If s < "9" And s > "0" Then
d = CInt(s)
Else

If s = "a" Then d = 10
If s = "b" Then d = 11
If s = "c" Then d = 12
If s = "d" Then d = 13
If s = "e" Then d = 14
If s = "f" Then d = 15
End If

da = da + d * 16 ^ 4

Case 4

If s < "9" And s > "0" Then
d = CInt(s)
Else

If s = "a" Then d = 10
If s = "b" Then d = 11
If s = "c" Then d = 12
If s = "d" Then d = 13
If s = "e" Then d = 14
If s = "f" Then d = 15
End If

da = da + d * 16 ^ 3

Case 5

If s < "9" And s > "0" Then
d = CInt(s)
Else

If s = "a" Then d = 10
If s = "b" Then d = 11
If s = "c" Then d = 12
If s = "d" Then d = 13
If s = "e" Then d = 14
If s = "f" Then d = 15
End If

da = da + d * 16 ^ 2

Case 6

If s < "9" And s > "0" Then
d = CInt(s)
Else

If s = "a" Then d = 10
If s = "b" Then d = 11
If s = "c" Then d = 12
If s = "d" Then d = 13
If s = "e" Then d = 14
If s = "f" Then d = 15
End If

da = da + d * 16 ^ 1

Case 7

If s < "9" And s > "0" Then
d = CInt(s)
Else

If s = "a" Then d = 10
If s = "b" Then d = 11
If s = "c" Then d = 12
If s = "d" Then d = 13
If s = "e" Then d = 14
If s = "f" Then d = 15
End If

da = da + d * 1
End Select

Next i

c16to10 = da
End Function

Private Sub read_data()
Dim s1, s2, s3 As String
s1 = "小寒大寒立春雨水惊蛰春分清明谷雨立夏小满芒种夏至小暑大暑立秋处暑白露秋分寒露霜降立冬小雪大雪冬至"
s2 = "000000,021208,042467,063836,085337,107014,128867,150921,173149,195551,218072,240693,263343,285989,308563,331033,353350,375494,397447,419210,440795,462224,483532,504758"
s3 = "JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC"

For i = 1 To 24
SolarTerm(i) = Mid(s1, (i - 1) * 2 + 1, 2)  '节气
sTermInfo(i) = Val(Mid(s2, (i - 1) * 7 + 1, 6))

If i <= 12 Then MonthName(i) = Mid(s3, (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(17) ="0918九·一八事变(中国国耻日)"
sFtv(18) = "0928孔子诞辰"
sFtv(19) = "1001中国国庆节"
sFtv(20) = "1006老人节"
sFtv(21) = "1024联合国日"
'sFtv(21) = "1031万圣节"
sFtv(22) = "1112孙中山诞辰"
'sFtv(21) = "1212西安事变纪念日"
'sFtv(21) = "南京大屠杀纪念日"
sFtv(23) = "1220澳门回归"
'sFtv(21) = "平安夜"
sFtv(24) = "1225圣诞节"
sFtv(25) = "1226毛诞辰纪念"

'农历的节日：日期表示的是农历的某月某日
lFtv(1) = "0101春节"
lFtv(2) = "0115元宵节"
lFtv(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) = "0637父亲节"
wFtv(5) = "0531胜利日"
wFtv(6) = "0716合作节"
wFtv(7) = "0730被奴周"
wFtv(8) = ""
wFtv(9) = ""
wFtv(10) = "1021哥伦布日"
wFtv(11) = "1144感恩节"

LunarInfo(1) = c16to10("ox04bd8")
LunarInfo(2) = c16to10("ox04ae0")
LunarInfo(3) = c16to10("ox0a570")
LunarInfo(4) = c16to10("ox054d5")
LunarInfo(5) = c16to10("ox0d260")
LunarInfo(6) = c16to10("ox0d950")
LunarInfo(7) = c16to10("ox16554")
LunarInfo(8) = c16to10("ox056a0")
LunarInfo(9) = c16to10("ox09ad0")
LunarInfo(10) = c16to10("ox055d2")

LunarInfo(11) = c16to10("ox04ae0")
LunarInfo(12) = c16to10("ox0a5b6")
LunarInfo(13) = c16to10("ox0a4d0")
LunarInfo(14) = c16to10("ox0d250")
LunarInfo(15) = c16to10("ox1d255")
LunarInfo(16) = c16to10("ox0b540")
LunarInfo(17) = c16to10("ox0d6a0")
LunarInfo(18) = c16to10("ox0ada2")
LunarInfo(19) = c16to10("ox095b0")
LunarInfo(20) = c16to10("ox14977")

LunarInfo(21) = c16to10("ox04970")
LunarInfo(22) = c16to10("ox0a4b0")
LunarInfo(23) = c16to10("ox0b4b5")
LunarInfo(24) = c16to10("ox06a50")
LunarInfo(25) = c16to10("ox06d40")
LunarInfo(26) = c16to10("ox1ab54")
LunarInfo(27) = c16to10("ox02b60")
LunarInfo(28) = c16to10("ox09570")
LunarInfo(29) = c16to10("ox052f2")
LunarInfo(30) = c16to10("ox04970")

LunarInfo(31) = c16to10("ox06566")
LunarInfo(32) = c16to10("ox0d4a0")
LunarInfo(33) = c16to10("ox0ea50")
LunarInfo(34) = c16to10("ox06e95")
LunarInfo(35) = c16to10("ox05ad0")
LunarInfo(36) = c16to10("ox02b60")
LunarInfo(37) = c16to10("ox186e3")
LunarInfo(38) = c16to10("ox092e0")
LunarInfo(39) = c16to10("ox1c8d7")
LunarInfo(40) = c16to10("ox0c950")

LunarInfo(41) = c16to10("ox0d4a0")
LunarInfo(42) = c16to10("ox1d8a6")
LunarInfo(43) = c16to10("ox0b550")
LunarInfo(44) = c16to10("ox056a0")
LunarInfo(45) = c16to10("ox1a5b4")
LunarInfo(46) = c16to10("ox025d0")
LunarInfo(47) = c16to10("ox092d0")
LunarInfo(48) = c16to10("ox0d2b2")
LunarInfo(49) = c16to10("ox0a950")
LunarInfo(50) = c16to10("ox0b557")

LunarInfo(51) = c16to10("ox06ca0")
LunarInfo(52) = c16to10("ox0b550")
LunarInfo(53) = c16to10("ox15355")
LunarInfo(54) = c16to10("ox04da0")
LunarInfo(55) = c16to10("ox0a5d0")
LunarInfo(56) = c16to10("ox14573")
LunarInfo(57) = c16to10("ox052d0")
LunarInfo(58) = c16to10("ox0a9a8")
LunarInfo(59) = c16to10("ox0e950")
LunarInfo(60) = c16to10("ox06aa0")

LunarInfo(61) = c16to10("ox0aea6")
LunarInfo(62) = c16to10("ox0ab50")
LunarInfo(63) = c16to10("ox04b60")
LunarInfo(64) = c16to10("ox0aae4")
LunarInfo(65) = c16to10("ox0a570")
LunarInfo(66) = c16to10("ox05260")
LunarInfo(67) = c16to10("ox0f263")
LunarInfo(68) = c16to10("ox0d950")
LunarInfo(69) = c16to10("ox05b57")
LunarInfo(70) = c16to10("ox056a0")

LunarInfo(71) = c16to10("ox096d0")
LunarInfo(72) = c16to10("ox04dd5")
LunarInfo(73) = c16to10("ox04ad0")
LunarInfo(74) = c16to10("ox0a4d0")
LunarInfo(75) = c16to10("ox0d4d4")
LunarInfo(76) = c16to10("ox0d250")
LunarInfo(77) = c16to10("ox0d558")
LunarInfo(78) = c16to10("ox0b540")
LunarInfo(79) = c16to10("ox0b5a0")
LunarInfo(80) = c16to10("ox195a6")

LunarInfo(81) = c16to10("ox095b0")
LunarInfo(82) = c16to10("ox049b0")
LunarInfo(83) = c16to10("ox0a974")
LunarInfo(84) = c16to10("ox0a4b0")
LunarInfo(85) = c16to10("ox0b27a")
LunarInfo(86) = c16to10("ox06a50")
LunarInfo(87) = c16to10("ox06d40")
LunarInfo(88) = c16to10("ox0af46")
LunarInfo(89) = c16to10("ox0ab60")
LunarInfo(90) = c16to10("ox09570")

LunarInfo(91) = c16to10("ox04af5")
LunarInfo(92) = c16to10("ox04970")
LunarInfo(93) = c16to10("ox064b0")
LunarInfo(94) = c16to10("ox074a3")
LunarInfo(95) = c16to10("ox0ea50")
LunarInfo(96) = c16to10("ox06b58")
LunarInfo(97) = c16to10("ox055c0")
LunarInfo(98) = c16to10("ox0ab60")
LunarInfo(99) = c16to10("ox096d5")
LunarInfo(100) = c16to10("ox092e0")

LunarInfo(101) = c16to10("ox0c960")
LunarInfo(102) = c16to10("ox0d954")
LunarInfo(103) = c16to10("ox0d4a0")
LunarInfo(104) = c16to10("ox0da50")
LunarInfo(105) = c16to10("ox07552")
LunarInfo(106) = c16to10("ox056a0")
LunarInfo(107) = c16to10("ox0abb7")
LunarInfo(108) = c16to10("ox025d0")
LunarInfo(109) = c16to10("ox092d0")
LunarInfo(110) = c16to10("ox0cab5")

LunarInfo(111) = c16to10("ox0a950")
LunarInfo(112) = c16to10("ox0b4a0")
LunarInfo(113) = c16to10("ox0baa4")
LunarInfo(114) = c16to10("ox0ad50")
LunarInfo(115) = c16to10("ox055d9")
LunarInfo(116) = c16to10("ox04ba0")
LunarInfo(117) = c16to10("ox0a5b0")
LunarInfo(118) = c16to10("ox15176")
LunarInfo(119) = c16to10("ox052b0")
LunarInfo(120) = c16to10("ox0a930")

LunarInfo(121) = c16to10("ox07954")
LunarInfo(122) = c16to10("ox06aa0")
LunarInfo(123) = c16to10("ox0ad50")
LunarInfo(124) = c16to10("ox05b52")
LunarInfo(125) = c16to10("ox04b60")
LunarInfo(126) = c16to10("ox0a6e6")
LunarInfo(127) = c16to10("ox0a4e0")
LunarInfo(128) = c16to10("ox0d260")
LunarInfo(129) = c16to10("ox0ea65")
LunarInfo(130) = c16to10("ox0d530")

LunarInfo(131) = c16to10("ox05aa0")
LunarInfo(132) = c16to10("ox076a3")
LunarInfo(133) = c16to10("ox096d0")
LunarInfo(134) = c16to10("ox04bd7")
LunarInfo(135) = c16to10("ox04ad0")
LunarInfo(136) = c16to10("ox0a4d0")
LunarInfo(137) = c16to10("ox1d0b6")
LunarInfo(138) = c16to10("ox0d250")
LunarInfo(139) = c16to10("ox0d520")
LunarInfo(140) = c16to10("ox0dd45")

LunarInfo(141) = c16to10("ox0b5a0")
LunarInfo(142) = c16to10("ox056d0")
LunarInfo(143) = c16to10("ox055b2")
LunarInfo(144) = c16to10("ox049b0")
LunarInfo(145) = c16to10("ox0a577")
LunarInfo(146) = c16to10("ox0a4b0")
LunarInfo(147) = c16to10("ox0aa50")
LunarInfo(148) = c16to10("ox1b255")
LunarInfo(149) = c16to10("ox06d20")
LunarInfo(150) = c16to10("ox0ada0")

End Sub
'传回农历 y年m月的总天数
Function lMonthDays(ByVal Y As Integer) As Integer
If Y < 1900 Then Y = 1900
If (LunarInfo(Y - 1900 + 1) And Int(&H10000 / (2 ^ 12))) = 0 Then
lMonthDays = 29
Else
lMonthDays = 30
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

Private Sub riliLoad(curtime As Date)
Dim mons        As String
Dim Twftv       As String
Dim TLftv       As String
Dim Tsftv       As String
Dim Twftv_s     As String
Dim Tlftv_s     As String
Dim TSftv_s     As String
Dim s1          As String
Dim s2          As String
Dim ls1         As String
Dim ls2         As String
Dim Nonglis     As String
Dim LTerm       As String
Dim YMD         As String
Dim days        As String
Dim LDays       As String
Dim Lmons       As String
Dim shuxiangStr As String
Dim tian        As Integer
Dim ss          As String
Dim ss1         As String
read_data
'获取当前系统时间
s1 = GetMonthWeek(curtime)
LTerm = GetTerm(curtime)
'curTime = "2004-05-01"
'星期名
WeekName(0) = " * "
WeekName(1) = "星期日"
WeekName(2) = "星期一"
WeekName(3) = "星期二"
WeekName(4) = "星期三"
WeekName(5) = "星期四"
WeekName(6) = "星期五"
WeekName(7) = "星期六"

'天干名称
TianGan(0) = "甲"
TianGan(1) = "乙"
TianGan(2) = "丙"
TianGan(3) = "丁"
TianGan(4) = "戊"
TianGan(5) = "己"
TianGan(6) = "庚"
TianGan(7) = "辛"
TianGan(8) = "壬"
TianGan(9) = "癸"

'地支名称
DiZhi(0) = "子"
DiZhi(1) = "丑"
DiZhi(2) = "寅"
DiZhi(3) = "卯"
DiZhi(4) = "辰"
DiZhi(5) = "巳"
DiZhi(6) = "午"
DiZhi(7) = "未"
DiZhi(8) = "申"
DiZhi(9) = "酉"
DiZhi(10) = "戌"
DiZhi(11) = "亥"

'属相名称
ShuXiang(0) = "鼠"
ShuXiang(1) = "牛"
ShuXiang(2) = "虎"
ShuXiang(3) = "兔"
ShuXiang(4) = "龙"
ShuXiang(5) = "蛇"
ShuXiang(6) = "马"
ShuXiang(7) = "羊"
ShuXiang(8) = "猴"
ShuXiang(9) = "鸡"
ShuXiang(10) = "狗"
ShuXiang(11) = "猪"

'农历日期名
DayName(0) = "*"
DayName(1) = "初一"
DayName(2) = "初二"
DayName(3) = "初三"
DayName(4) = "初四"
DayName(5) = "初五"
DayName(6) = "初六"
DayName(7) = "初七"
DayName(8) = "初八"
DayName(9) = "初九"
DayName(10) = "初十"
DayName(11) = "十一"
DayName(12) = "十二"
DayName(13) = "十三"
DayName(14) = "十四"
DayName(15) = "十五"
DayName(16) = "十六"
DayName(17) = "十七"
DayName(18) = "十八"
DayName(19) = "十九"
DayName(20) = "二十"
DayName(21) = "廿一"
DayName(22) = "廿二"
DayName(23) = "廿三"
DayName(24) = "廿四"
DayName(25) = "廿五"
DayName(26) = "廿六"
DayName(27) = "廿七"
DayName(28) = "廿八"
DayName(29) = "廿九"
DayName(30) = "三十"

'农历月份名
MonName(0) = "*"
MonName(1) = "正"
MonName(2) = "二"
MonName(3) = "三"
MonName(4) = "四"
MonName(5) = "五"
MonName(6) = "六"
MonName(7) = "七"
MonName(8) = "八"
MonName(9) = "九"
MonName(10) = "十"
MonName(11) = "十一"
MonName(12) = "腊"

'公历每月前面的天数
MonthAdd(0) = 0
MonthAdd(1) = 31
MonthAdd(2) = 59
MonthAdd(3) = 90
MonthAdd(4) = 120
MonthAdd(5) = 151
MonthAdd(6) = 181
MonthAdd(7) = 212
MonthAdd(8) = 243
MonthAdd(9) = 273
MonthAdd(10) = 304
MonthAdd(11) = 334
'农历数据
NongliData(0) = 2635
NongliData(1) = 333387
NongliData(2) = 1701
NongliData(3) = 1748
NongliData(4) = 267701
NongliData(5) = 694
NongliData(6) = 2391
NongliData(7) = 133423
NongliData(8) = 1175
NongliData(9) = 396438
NongliData(10) = 3402
NongliData(11) = 3749
NongliData(12) = 331177
NongliData(13) = 1453
NongliData(14) = 694
NongliData(15) = 201326
NongliData(16) = 2350
NongliData(17) = 465197
NongliData(18) = 3221
NongliData(19) = 3402
NongliData(20) = 400202
NongliData(21) = 2901
NongliData(22) = 1386
NongliData(23) = 267611
NongliData(24) = 605
NongliData(25) = 2349
NongliData(26) = 137515
NongliData(27) = 2709
NongliData(28) = 464533
NongliData(29) = 1738
NongliData(30) = 2901
NongliData(31) = 330421
NongliData(32) = 1242
NongliData(33) = 2651
NongliData(34) = 199255
NongliData(35) = 1323
NongliData(36) = 529706
NongliData(37) = 3733
NongliData(38) = 1706
NongliData(39) = 398762
NongliData(40) = 2741
NongliData(41) = 1206
NongliData(42) = 267438
NongliData(43) = 2647
NongliData(44) = 1318
NongliData(45) = 204070
NongliData(46) = 3477
NongliData(47) = 461653
NongliData(48) = 1386
NongliData(49) = 2413
NongliData(50) = 330077
NongliData(51) = 1197
NongliData(52) = 2637
NongliData(53) = 268877
NongliData(54) = 3365
NongliData(55) = 531109
NongliData(56) = 2900
NongliData(57) = 2922
NongliData(58) = 398042
NongliData(59) = 2395
NongliData(60) = 1179
NongliData(61) = 267415
NongliData(62) = 2635
NongliData(63) = 661067
NongliData(64) = 1701
NongliData(65) = 1748
NongliData(66) = 398772
NongliData(67) = 2742
NongliData(68) = 2391
NongliData(69) = 330031
NongliData(70) = 1175
NongliData(71) = 1611
NongliData(72) = 200010
NongliData(73) = 3749
NongliData(74) = 527717
NongliData(75) = 1452
NongliData(76) = 2742
NongliData(77) = 332397
NongliData(78) = 2350
NongliData(79) = 3222
NongliData(80) = 268949
NongliData(81) = 3402
NongliData(82) = 3493
NongliData(83) = 133973
NongliData(84) = 1386
NongliData(85) = 464219
NongliData(86) = 605
NongliData(87) = 2349
NongliData(88) = 334123
NongliData(89) = 2709
NongliData(90) = 2890
NongliData(91) = 267946
NongliData(92) = 2773
NongliData(93) = 592565
NongliData(94) = 1210
NongliData(95) = 2651
NongliData(96) = 395863
NongliData(97) = 1323
NongliData(98) = 2707
NongliData(99) = 265877
'生成当前公历年、月、日 ==> GongliStr

curYear = Year(curtime)
curMonth = Month(curtime)
curDay = Day(curtime)
YMD = curYear & "年" & curMonth & "月" & curDay & "日"

If curMonth < 10 Then '月变成双字符
mons = "0" & curMonth
Else
mons = curMonth
End If

If curDay < 10 Then '日变成双字符
days = "0" & curDay
Else
days = curDay
End If

s2 = mons & days '集合月日/-/MMDD
GongliStr = curYear & "年"

If (curMonth < 10) Then
GongliStr = GongliStr & "0" & curMonth & "月"
Else
GongliStr = GongliStr & curMonth & "月"
End If

If (curDay < 10) Then
GongliStr = GongliStr & "0" & curDay & "日"
Else
GongliStr = GongliStr & curDay & "日"
End If

'生成当前公历星期 ==> WeekdayStr
curWeekday = Weekday(curtime)
WeekdayStr = WeekName(curWeekday)
'计算到初始时间1921年2月8日的天数：1921-2-8(正月初一)
TheDate = (curYear - 1921) * 365 + Int((curYear - 1921) / 4) + curDay + MonthAdd(curMonth - 1) - 38

If ((curYear Mod 4) = 0 And curMonth > 2) Then
TheDate = TheDate + 1
End If

'计算农历天干、地支、月、日
isEnd = 0
m = 0

Do

If (NongliData(m) < 4095) Then
k = 11
Else
k = 12
End If

n = k

Do

If (n < 0) Then
Exit Do
End If

'获取NongliData(m)的第n个二进制位的值
bit = NongliData(m)

For i = 1 To n Step 1
bit = Int(bit / 2)
Next

bit = bit Mod 2

If (TheDate <= 29 + bit) Then
isEnd = 1
Exit Do
End If

TheDate = TheDate - 29 - bit

n = n - 1
Loop

If (isEnd = 1) Then
Exit Do
End If

m = m + 1
Loop

curYear = 1921 + m
curMonth = k - n + 1
curDay = TheDate

If curDay < 10 Then '农历日变成双字符
LDays = "0" & curDay
Else
LDays = curDay
End If

If (k = 12) Then
If (curMonth = (Int(NongliData(m) / 65536) + 1)) Then
curMonth = 1 - curMonth
ElseIf (curMonth > (Int(NongliData(m) / 65536) + 1)) Then
curMonth = curMonth - 1
End If

End If

'生成农历天干、地支、属相 ==> NongliStr
NongliStr = TianGan(((curYear - 4) Mod 60) Mod 10) & DiZhi(((curYear - 4) Mod 60) Mod 12) & "年"
shuxiangStr = ShuXiang(((curYear - 4) Mod 60) Mod 12)

'生成农历月、日 ==> NongliDayStr
If curMonth = 12 Then tian = lMonthDays(curYear)
If (curMonth < 1) Then
NongliDayStr = "闰" & MonName(-1 * curMonth)
Else
NongliDayStr = MonName(curMonth)
End If

If curMonth < 10 Then '农历月变成双字符
Lmons = "0" & curMonth
Else
Lmons = curMonth
End If

ls1 = Lmons & LDays
NongliDayStr = NongliDayStr & "月"
NongliDayStr = NongliDayStr & DayName(curDay)
Nonglis = NongliStr & NongliDayStr 'xu chu

For i = 1 To 11 '找以周计算的节日
Twftv = Mid(wFtv(i), 1, 4)

If Twftv = s1 Then
Twftv_s = Mid(wFtv(i), 5, 3)
Exit For
End If

Next i

For i = 1 To 25 '找以公历的节日
Tsftv = Mid(sFtv(i), 1, 4)

If Tsftv = s2 Then
TSftv_s = Mid(sFtv(i), 5, 6)
Exit For
End If

Next i

For i = 1 To 11 '找农历的节日
TLftv = Mid(lFtv(i), 1, 4)

If TLftv = ls1 Then
Tlftv_s = Mid(lFtv(i), 5, 3)
Exit For
End If

Next i

If ls1 = "12" & tian Then Tlftv_s = Mid(lFtv(11), 5, 3)

ss = "今天是" & YMD & Chr(13) & "农历:" & Nonglis & Chr(13) & "属象:" & shuxiangStr & "年" & Chr(13)
ss1 = ""

If Tlftv_s <> "" Then ss1 = ss1 & Tlftv_s
If Twftv_s <> "" Then ss1 = ss1 & Twftv_s
If TSftv_s <> "" Then ss1 = ss1 & TSftv_s
If LTerm <> "" Then ss1 = ss1 & LTerm
If ss1 <> " " Then ss = ss & "今天是：" & ss1
Label1.Caption = ss
End Sub

Private Sub Check1_Click()

If Check1.Value = 1 Then
Combo1.Enabled = True
Combo2.Enabled = True
Combo3.Enabled = True
Else
Check1.Value = 0
Combo1.Enabled = False
Combo2.Enabled = False
Combo3.Enabled = False
End If

End Sub

Private Sub Combo2_LostFocus()
Combo3.Clear
Dim i As Integer
Dim d As Integer

Select Case CInt(Combo2.Text)

Case 1, 3, 5, 7, 8, 10, 12

For i = 1 To 31
Combo3.AddItem i, i - 1
Next i

Case 4, 6, 9, 11

For i = 1 To 30
Combo3.AddItem i, i - 1
Next i

Case 2

If Combo1.Text Mod 4 = 0 Then
d = 29
Else
d = 28
End If

For i = 1 To d
Combo3.AddItem i, i - 1
Next i

End Select

End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
settime = Combo1.Text & "-" & Combo2.Text & "-" & Combo3.Text
riliLoad (settime)
End Sub

Private Sub Form_Load()

Check1.Value = 0
Combo1.Enabled = False
Combo2.Enabled = False
Combo3.Enabled = False

Combo1.Text = Year(Date)
Combo2.Text = Month(Date)
Combo3.Text = Day(Date)
riliLoad (Date)
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
settime = Combo1.Text & "-" & Combo2.Text & "-" & Combo3.Text
riliLoad (settime)
End Sub