123.bas

一个很漂亮的日历

   '***************************************************
   '*  返回dY年dM月dD日农历的节气    *
   '***************************************************
   Dim i As Integer, j As Integer, dY As Integer, dM As Integer, dD As Integer
   Dim D As String, D1 As String, D2 As String, DDD As Date
   Dim DDD1 As Date, DDD2 As Date, Ddd3 As Date
        dY = Year(ddy)
        dM = Month(ddy)
        dD = Day(ddy)
          
        D = Trim(Str(Year(ddy))) + "," + Trim(Str(Month(ddy))) + "," + Trim(Str(15 - Val(Mid(seaSonY(dY - 1901), ((dM - 1) * 4 + 1), 2))))
        D1 = Trim(Str(Year(ddy))) + "," + Trim(Str(Month(ddy))) + "," + Trim(Str(15 + Val(Mid(seaSonY(dY - 1901), ((dM - 1) * 4 + 3), 2))))
        If Month(ddy) > 1 Then
           D2 = Trim(Str(Year(ddy))) + "," + Trim(Str(Month(ddy) - 1)) + "," + Trim(Str(15 + Val(Mid(seaSonY(dY - 1901), ((dM - 2) * 4 + 3), 2))))
        Else
           D2 = Trim(Str(Year(ddy) - 1)) + "," + Trim(Str(12)) + "," + Trim(Str(15 + Val(Mid(seaSonY(dY - 1901), ((dM + 12 - 2) * 4 + 3), 2))))
        End If
           DDD = D
           DDD1 = D1
           DDD2 = D2
        If ddy >= DDD Then
             seaSonYx = solarTerm((dM - 1) * 2) + "第" + Trim(Str(ddy - DDD + 1)) + "天"
        Else
          If dM < 2 Then
            seaSonYx = solarTerm(11 * 2 + 1) + "第" + Trim(Str(ddy - DDD2 + 1)) + "天"
          Else
            seaSonYx = solarTerm((dM - 2) * 2 + 1) + "第" + Trim(Str(ddy - DDD2 + 1)) + "天"
          End If
        End If
        If ddy >= DDD1 Then
             seaSonYx = solarTerm((dM - 1) * 2 + 1) + "第" + Trim(Str(ddy - DDD1 + 1)) + "天"
        End If
End Function

Public Function ssFtv(m As Integer, D As Integer)
  Dim aa
   '***************************************************
   '*          返回阳历M月D日的节日             *
   '***************************************************
   For aa = 0 To 30
     If (Val(Mid(sFtv(aa), 1, 2)) = m) And (Val(Mid(sFtv(aa), 3, 2)) = D) Then
'        If aa >= 10 And aa <= 25 Then
          ssFtv = Mid(sFtv(aa), 5, LenB(sFtv(aa)) - 5)
'        Else
'          ssFtv = Mid(sFtv(aa), 5, LenB(sFtv(aa)) - 5)
'        End If
     End If
   Next aa
End Function
Public Function yTGDZ(y As Integer)
   '***************************************************
   '*          返回农历y年的天干、地支             *
   '***************************************************
  yTGDZ = Gan((y - 1894) Mod 10) + Zhi((y - 1901) Mod 12)
End Function

Public Function llFtv(m As Integer, D As Integer)
   '***************************************************
   '*          返回农历M月D日的节日             *
   '***************************************************
   Dim aa As Integer
      llFtv = ""
   For aa = 0 To 30
     If (Val(Mid(lFtv(aa), 1, 2)) = m) And (Val(Mid(lFtv(aa), 3, 2)) = D) Then
        If aa >= 10 And aa <= 25 Then
           llFtv = Mid(lFtv(aa), 5, LenB(lFtv(aa)) - 4) + "happy birthday"
        Else
           llFtv = Mid(lFtv(aa), 5, LenB(lFtv(aa)) - 4)
        End If
     End If
     
   Next aa
End Function

Public Function sdayF_gzr(dY As Date)
   '***************************************************
   '*          返回农历y年M月D日的天干、地支             *
   '***************************************************
   Dim dE As Date, dK As Long
   dE = #2/15/1901#
   dK = dY - dE
   
  sdayF_gzr = Gan(dK Mod 10) + Zhi((dK - 1) Mod 12)

End Function
   

Public Function sdayF_gzm(dY As Integer, dM As Integer)
   '***************************************************
   '*          返回农历y年M月的天干、地支             *
   '***************************************************
   Dim dK As Long
   dK = (dY - 1901) * 12 + dM
   sdayF_gzm = Gan((dK + 5) Mod 10) + Zhi((dK) Mod 12)

End Function
Public Function seaSonYxr(dY As Date)
   '***************************************************
   '*  返回dY年dM月dD日农历的九九  伏  *
   '***************************************************
   Dim dE As Date, dK As Long, Val_1 As Integer
   Dim D As String, D1 As String, D2 As String, DDD As Date
   Dim i As Integer, DDD1 As Date, DDD2 As Date, Ddd3 As Date
    dE = #2/15/1901#
    i = 0
        D = Trim(Str(Year(dY) - 1)) + ",12," + Trim(Str(15 + Val(Right(seaSonY(Year(dY) - 1900), 2))))
        D1 = Trim(Str(Year(dY))) + ",6," + Trim(Str(15 + Val(Mid(seaSonY(Year(dY) - 1901), 23, 2))))
        D2 = Trim(Str(Year(dY))) + ",12," + Trim(Str(15 + Val(Right(seaSonY(Year(dY) - 1901), 2))))
        DDD = D
        DDD1 = D1
        Ddd3 = DDD1
        DDD2 = D2
        If ((dY >= DDD) And (dY < DDD1)) Then
           If dY - DDD < 81 Then
              seaSonYxr = nStr1(Int((dY - DDD) / 9) + 1) + "九第" + nStr1(((dY - DDD) Mod 9) + 1) + "天"
           Else
              seaSonYxr = "越来越暖和"
           End If
        ElseIf ((dY >= DDD1) And (dY < DDD2 - 30)) Then
                While i < 3
                  dK = Ddd3 - dE
                  If Gan1(dK Mod 10) = "ge" Then i = i + 1
                  Ddd3 = Ddd3 + 1
                Wend
                  Val_1 = Int((dY - Ddd3 + 1) / 10)
                  Select Case Val_1
                      Case 0
                        seaSonYxr = "初伏第" + nStr1(((dY - Ddd3 + 1) Mod 10) + 1) + "天"
                      Case 1
                        seaSonYxr = "中伏第" + nStr1(((dY - Ddd3 + 1) Mod 10) + 1) + "天"
                      Case 2
                        seaSonYxr = "中伏第十" + nStr1(((dY - Ddd3 + 1) Mod 10) + 1) + "天"
                      Case 3
                        seaSonYxr = "大伏第" + nStr1(((dY - Ddd3 + 1) Mod 10) + 1) + "天"
                      Case Else
                       If Val_1 < 4 Then
                        seaSonYxr = "快入伏天啦"
                       
                       Else
                        seaSonYxr = "越来越凉爽"
                       End If
                  End Select
        ElseIf ((dY >= (DDD2 - 30)) And (dY < DDD2 - 10)) Then
                   seaSonYxr = "越来越冷啦"
        ElseIf ((dY >= (DDD2 - 10)) And (dY < DDD2)) Then
                   seaSonYxr = "快到数九寒天啦"
        ElseIf (dY >= DDD2) Then
                   seaSonYxr = nStr1(Int((dY - DDD2) / 9) + 1) + "九第" + nStr1(((dY - DDD2) Mod 9) + 1) + "天"
                
        End If

End Function

Public Sub sub_For(kKk As Integer, yL As Integer)
    Dim i
    For i = 1 To kKk
      If i = Val(Mid(yearDate(yL), 14, 2)) + 1 Then
         If (i - 1) < 10 Then
           lmName(i) = "Y0" + Trim(Str(i - 1)) + "Month"
         Else
           lmName(i) = "Y" + Trim(Str(i - 1)) + "Month"
         End If
      Else
         If i < Val(Mid(yearDate(yL), 14, 2)) + 1 Then
           If i < 10 Then
             lmName(i) = "00" + Trim(Str(i)) + "Month"
           Else
             lmName(i) = "0" + Trim(Str(i)) + "Month"
           End If
         Else
           If (i - 1) < 10 Then
             lmName(i) = "00" + Trim(Str(i - 1)) + "Month"
           Else
             lmName(i) = "0" + Trim(Str(i - 1)) + "Month"
           End If
         End If
      End If
      If Val(Mid(yearDate(yL), i, 1)) = "1" Then
            lmName(i) = lmName(i) + "Big"
      Else
            lmName(i) = lmName(i) + "Sma"
      End If
    Next i
End Sub
Public Sub sub_For1(kKk As Integer, yL As Integer)
    Dim i
    For i = 1 To kKk
        If i < 10 Then
           lmName(i) = "00" + Trim(Str(i)) + "Month"
        Else
           lmName(i) = "0" + Trim(Str(i)) + "Month"
        End If
        If Val(Mid(yearDate(yL), i, 1)) = "1" Then
          lmName(i) = lmName(i) + "Big"
        Else
          lmName(i) = lmName(i) + "Sma"
        End If
    Next i

End Sub