123.bas

一个很漂亮的日历

Attribute VB_Name = "Module1"
'Option Explicit
Public Gan(10) As String
Public Gan1(10) As String
Public Zhi(12) As String
Public Animals(12) As String
Public solarTerm(24)
Public sTermInfo(24)
Public nStr1(12), nStr2(4)
Public monthName(12) As String
Public seaSonY(150) As String
Public yearDate(150) As String
Public lmName(13) As String, sFtv(30) As String, lFtv(30) As String

Public Sub shxing()
    Gan(0) = "甲": Gan(1) = "乙": Gan(2) = "丙": Gan(3) = "丁": Gan(4) = "戊": Gan(5) = "己": Gan(6) = "庚": Gan(7) = "辛": Gan(8) = "壬": Gan(9) = "癸"
    Gan1(0) = "ja": Gan1(1) = "yi": Gan1(2) = "bi": Gan1(3) = "di": Gan1(4) = "wu": Gan1(5) = "ji": Gan1(6) = "ge": Gan1(7) = "xi": Gan1(8) = "re": Gan1(9) = "ku"
    Zhi(11) = "子": Zhi(0) = "丑": Zhi(1) = "寅": Zhi(2) = "卯": Zhi(3) = "辰": Zhi(4) = "巳": Zhi(5) = "午": Zhi(6) = "未": Zhi(7) = "申": Zhi(8) = "酉": Zhi(9) = "戌": Zhi(10) = "亥"
    Animals(0) = "鼠": Animals(1) = "牛": Animals(2) = "虎": Animals(3) = "兔": Animals(4) = "龙": Animals(5) = "蛇": Animals(6) = "马": Animals(7) = "羊": Animals(8) = "猴": Animals(9) = "鸡": Animals(10) = "狗": Animals(11) = "猪"
    '
    solarTerm(0) = "小寒": solarTerm(1) = "大寒": solarTerm(2) = "立春": solarTerm(3) = "雨水": solarTerm(4) = "惊蛰": solarTerm(5) = "春分": solarTerm(6) = "清明": solarTerm(7) = "谷雨": solarTerm(8) = "立夏": solarTerm(9) = "小满": solarTerm(10) = "芒种": solarTerm(11) = "夏至"
    solarTerm(12) = "小暑": solarTerm(13) = "大暑": solarTerm(14) = "立秋": solarTerm(15) = "处暑": solarTerm(16) = "白露": solarTerm(17) = "秋分": solarTerm(18) = "寒露": solarTerm(19) = "霜降": solarTerm(20) = "立冬": solarTerm(21) = "小雪": solarTerm(22) = "大雪": solarTerm(23) = "冬至"
    
    nStr1(0) = "日": nStr1(1) = "一": nStr1(2) = "二": nStr1(3) = "三": nStr1(4) = "四": nStr1(5) = "五": nStr1(6) = "六": nStr1(7) = "七": nStr1(8) = "八": nStr1(9) = "九": nStr1(10) = "十": nStr1(11) = "十一": nStr1(12) = "十二"
    nStr2(0) = "初": nStr2(1) = "十": nStr2(2) = "廿": nStr2(3) = "卅": nStr2(4) = "　"
    sFtv(0) = "0101*元旦": sFtv(1) = "0214 情人节": sFtv(2) = "": sFtv(3) = "0308 妇女节": sFtv(4) = "0312 植树节": sFtv(5) = "0315 消费者权益日": sFtv(6) = "0317 ": sFtv(7) = "0401 愚人节": sFtv(8) = "0501 劳动节": sFtv(9) = "0504 青年节": sFtv(10) = "0512 护士节": sFtv(11) = "": sFtv(12) = "0601 儿童节": sFtv(13) = ""
    sFtv(14) = "0701 建党节 香港回归纪念": sFtv(15) = "": sFtv(16) = "0718 ": sFtv(17) = "0801 建军节": sFtv(18) = "0808 父亲节": sFtv(19) = "0909 毛泽东逝世纪念": sFtv(20) = "0910 教师节": sFtv(21) = "0928 孔子诞辰": sFtv(22) = "1001*国庆节": sFtv(23) = "1006 老人节": sFtv(24) = "1024 联合国日": sFtv(25) = "1111 ": sFtv(26) = "1112 孙中山诞辰纪念": sFtv(27) = "1220 澳门回归纪念": sFtv(28) = "1225 Christmas Day": sFtv(29) = "1226 毛泽东诞辰纪念"
    lFtv(0) = "0101*春节": lFtv(1) = "0115 元宵节": lFtv(2) = "0505 端午节": lFtv(3) = "0707 七夕情人节": lFtv(4) = "0715 中元节": lFtv(5) = "0815 中秋节": lFtv(6) = "0909 重阳节": lFtv(7) = "1208 腊八节": lFtv(8) = "1223 小年": lFtv(9) = "0100*除夕"
    monthName(0) = "JAN": monthName(1) = "FEB": monthName(2) = "MAR": monthName(3) = "APR": monthName(4) = "MAY": monthName(5) = "JUN": monthName(6) = "JUL": monthName(7) = "AUG": monthName(8) = "SEP": monthName(9) = "OCT": monthName(10) = "NOV": monthName(11) = "DEC"
    seaSonY(100) = "100511031005100510061006080808080808070808070807/" '2001
    seaSonY(101) = "100511040906100509060906080807080708070808070807/"
    seaSonY(102) = "090511040906100509060907080807080708060907080807/"
    seaSonY(103) = "090611041005110510061006080708080808070808070806/"
    seaSonY(104) = "100511031005100510061006080808080808070808070807/"
    seaSonY(105) = "100511040906100510060906080808080708070808070807/"
    seaSonY(106) = "090511040906100509060907080807080708060907080807/"
    seaSonY(107) = "090611041005110510061006080708080807070808070806/"
    seaSonY(108) = "100511031005110510061006080808080808070808070807/"
    seaSonY(109) = "100511040906100510060906080808080708070808070807/"
    seaSonY(110) = "090511040906100509060907080807080708070907080807/"
    seaSonY(111) = "090611041005110510051006080708080807070808070806/"
    seaSonY(112) = "100511031005110510061006080708080808070808070807/"
    seaSonY(113) = "100511040906100510060906080808080708070808070807/"
    seaSonY(114) = "090511040906100509060907080807080708070907070807/"
    seaSonY(115) = "090511041005110410051006080708080807070808070806/"
    seaSonY(116) = "100513031005110510061006080708080808070808070807/"
    seaSonY(117) = "100511041006100510060906080808080708070808070807/"
    seaSonY(118) = "100511040906100509060906080807080708070907070807/"
    seaSonY(119) = "090511041005110410051006090708070807070808070806/"
    seaSonY(120) = "100513031005110510061006080708080808070808070806/"
    seaSonY(121) = "100511041005100510060906080808080808070808070807/"
    seaSonY(122) = "100511040906100509060906080807080708070907070807/"
    seaSonY(123) = "090511041005110410051006090708070807070808070906/"
    seaSonY(124) = "100513031005110510061006080708080808070808070806/"
    seaSonY(125) = "100511031005100510061006080808080808070808070807/"
    seaSonY(126) = "100511040906100509060906080807080708070808070807/"
    seaSonY(127) = "090511041005110410051006090708070807070808070906/"
    seaSonY(128) = "100513031005110510061006080708080808070808070806/"
    seaSonY(129) = "100511031005100510061006080808080808070808070807/"
    seaSonY(130) = "100511040906100509060906080807080708070808070807/"
    seaSonY(131) = "090511041005110410051006090708070807070808070906/"
    seaSonY(132) = "100513031005110510061006080808080808070808070806/"
    seaSonY(133) = "100511031005100510061006080807080808070808070807/"
    seaSonY(134) = "100511040906100510060906080808080708070808070807/"
    seaSonY(135) = "090511041005110410051006090708070807070808070906/"
    seaSonY(136) = "100513031005110510061006080708080808070808070806/"
    seaSonY(137) = "100511031005100510061006080808080808070808070807/"
    seaSonY(138) = "100511040906100510060906080808080708070808070807/"
    seaSonY(139) = "090511041005110410051006090708070807070808070906/"
    seaSonY(140) = "100513031005110510051006080708080807070808070806/"
    seaSonY(141) = "100511031005110510061006080808080808070808070807/"
    seaSonY(142) = "100511040906100510060906080808080708070808070807/"
    seaSonY(143) = "090511041005110410051006090708070807080808070906/"
    seaSonY(144) = "100513031005110410051006080708080807070808070806/"
    seaSonY(145) = "100511031005110510061006080708080808070808070807/"
    seaSonY(146) = "100511040906100510060906080808080708070808070807/"
    seaSonY(147) = "090511041005110410051005090708070807080808060906/"
    seaSonY(148) = "100412031005100510051006090708070807070808070806/"
    seaSonY(149) = "100512031005110510061006080708080708070808070807/"
    For i = 0 To 99
       seaSonY(145) = "101010101010101010101010101010101010101010101010"
       yearDate(i) = "0000000000000000"
    Next i
    yearDate(100) = "1101010010101041": yearDate(101) = "1101010010100000": yearDate(102) = "1101101001010000": yearDate(103) = "0101101010101021": yearDate(104) = "0101011010100000": yearDate(105) = "1010101011011071": yearDate(106) = "0010010111010000": yearDate(107) = "1001001011010000": yearDate(108) = "1100100101011051": yearDate(109) = "1010100101010000"
    yearDate(110) = "1011010010100000": yearDate(111) = "1011010101010041": yearDate(112) = "1010110101010000": yearDate(113) = "0101010110101091": yearDate(114) = "0100101110100000": yearDate(115) = "1010010110110000": yearDate(116) = "0101001010111061": yearDate(117) = "0101001010110000": yearDate(118) = "1010100100110000": yearDate(119) = "0111010010101041"
    yearDate(120) = "0110101010100000": yearDate(121) = "1010110101010000": yearDate(122) = "0100110110101021": yearDate(123) = "0100101101100000": yearDate(124) = "1010010101110061": yearDate(125) = "1010010011100000": yearDate(126) = "1101001001100000": yearDate(127) = "1110100100110051": yearDate(128) = "1101010100110000": yearDate(129) = "0101101010100000"
    yearDate(130) = "0110101101010031": yearDate(131) = "1001011011010000": yearDate(132) = "0100101011101111": yearDate(133) = "0100101011010000": yearDate(134) = "1010010011010000": yearDate(135) = "1101001001011061": yearDate(136) = "1101001001010000": yearDate(137) = "1101010100100000": yearDate(138) = "1101101010100051": yearDate(139) = "1011010110100000"
    yearDate(140) = "0101011011010000": yearDate(141) = "0100101011011021": yearDate(142) = "0100100110110000": yearDate(143) = "1010010010111071": yearDate(144) = "1010010010110000": yearDate(145) = "1010101001010000": yearDate(146) = "1011010100101051": yearDate(147) = "0110110100100000": yearDate(148) = "1010110110100000": yearDate(149) = "0101010110110031"
End Sub
Public Function cDay(D As Integer)
    Select Case D
      Case 10:
         s = "初十"
      Case 20:
         s = "二十"
         
      Case 30:
         s = "三十"
      
      Case Else
         s = nStr2(Int(D / 10))
         s = s + nStr1(D Mod 10)
      End Select
      cDay = s
End Function


'*******************************************************
'计算Y年一年的天数 =lsdayYear ,Y的值应在1901___2050之间
'*******************************************************
Public Function lsdayYear(y As Integer)
  Dim sSum As Integer, j
   sSum = 0
     For j = 1 To 12
        If (Mid(yearDate(y - 1901), j, 1) = "1") Then
           sSum = sSum + 30
        Else
           sSum = sSum + 29
        End If
     Next j
     If (Right(yearDate(y - 1901), 1) = "1") Then
        If (Mid(yearDate(y - 1901), 13, 1) = "1") Then
           sSum = sSum + 30
        Else
           sSum = sSum + 29
        End If
     End If
   lsdayYear = sSum
End Function


Public Function sdayF(dY As Integer, dM As Integer, dD As Integer)
   
   Dim dE As Date, dH As String, sSum1, kKk As Integer, yL As Integer, i As Integer, dJ As Date, dK
   Dim lLl As String
   dE = #2/19/1901#
   dH = Trim(Str(dY)) + "," + Trim(Str(dM)) + "," + Trim(Str(dD))
   dJ = dH
   dK = dJ - dE
   yL = dY - 1901
   sSum1 = 0
   '***************************************************
   '*  计算dY年dM月dD日到1901年2月19日的农历的总天数  *
   '***************************************************
        For i = 0 To yL
            sSum1 = sSum1 + lsdayYear(i + 1901)
        Next i
   '***************************************************
           If Right(yearDate(yL), 1) = "1" Then
              kKk = 13
   '***************************************************
   '*  返回dY年dM月dD日农历的月份大小                 *
   '***************************************************
               sub_For kKk, yL
           Else
               If Right(yearDate(yL), 1) = "0" Then
                      kKk = 12
                      sub_For1 kKk, yL
               End If
            End If
        While (sSum1 > dK)
            If (Mid(yearDate(yL), kKk, 1) = "1") Then
               sSum1 = sSum1 - 30
            Else
               sSum1 = sSum1 - 29
            End If
            If sSum1 > dK Then
                  kKk = kKk - 1
           
                 If ((kKk = 0) And (Right(yearDate(yL - 1), 1) = "1")) Then
                    kKk = 13
                    yL = yL - 1
        '***************************************************
        '*  返回dY年dM月dD日农历的月份大小                 *
        '***************************************************
                    sub_For kKk, yL
                 Else
                     If ((kKk = 0) And (Right(yearDate(yL - 1), 1) = "0")) Then
                           kKk = 12
                           yL = yL - 1
                           sub_For1 kKk, yL
                           
                     End If
                    
                 End If
            End If
        Wend
   '***************************************************
   '*  返回dY年dM月dD日农历的 年份  月份  日  节气    *
   '***************************************************
     If (dK - sSum1 + 1) < 10 Then
       lLl = "0" + Trim(Str(dK - sSum1 + 1))
     Else
       lLl = Trim(Str(dK - sSum1 + 1))
     End If
     sdayF = Trim(Str(yL + 1901)) + "Year" + lmName(kKk) + lLl + seaSonYx(dJ)
     
     sdayF = sdayF + llFtv(kKk, dK - sSum1 + 1)

End Function

Public Function seaSonYx(ddy As Date)