转载-公历转换农历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

 

转载于:https://www.cnblogs.com/xbj-hyml/p/3628875.html