module1.bas

vb编写的中国日梭万年历,可查询年1583-99999年

    Dim eposb(3) As Double, evelb(3) As Double, eposh(3) As Double, evelh(3) As Double
    Dim y As Double, dummy As Double, secdiff As Double, tdb As Double, lighttime As Double
    Call tdb2tdt(T, dummy, secdiff)
    tdb = T + secdiff / 86400#
    Call solarsystem(tdb, 3, HELIOC, eposh, evelh)
    Call solarsystem(tdb, 3, BARYC, eposb, evelb)
    'Convert to geocentric sun position
    spos(0) = -eposh(0)
    spos(1) = -eposh(1)
    spos(2) = -eposh(2)
    lighttime = Sqr(spos(0) * spos(0) + spos(1) * spos(1) + spos(2) * spos(2)) / C_
    Call aberration(spos, evelb, lighttime, sposg)
    Call precession(T0, sposg, tdb, spos)
    Call nutate(tdb, FN0, spos, sposg)
    y = Sqr(sposg(1) * sposg(1) + sposg(2) * sposg(2))
    y = y * IIf((sposg(1) > 0#), 1#, -1#)
    timeangle = Atn2(y, sposg(0)) + PI / 2#
    If (timeangle < 0#) Then timeangle = timeangle + 2# * PI
    timeangle = timeangle * 180# / PI
End Function
Private Function termtime(ByVal tstart As Double, ByVal tend As Double, ByVal termang As Double) As Double
    Dim tl As Double, tu As Double, tdif As Double, f As Double, vs As Double, ve As Double, vl As Double, vu As Double
    f = (Sqr(5#) - 1#) / 2#
    vs = Abs(timeangle(tstart) - termang)
    ve = Abs(timeangle(tend) - termang)
    tdif = f * (tend - tstart)
    tl = tend - tdif
    tu = tstart + tdif
    vl = Abs(timeangle(tl) - termang)
    vu = Abs(timeangle(tu) - termang)
    While (tend - tstart > errlimit)
        If (vl < vu And vl < vs And vl < ve Or vs < vu And vs < vl And vs < ve) Then
            tend = tu
            ve = vu
            tu = tl
            vu = vl
            tdif = f * (tend - tstart)
            tl = tend - tdif
            vl = Abs(timeangle(tl) - termang)
        Else
            tstart = tl
            vs = vl
            tl = tu
            vl = vu
            tdif = f * (tend - tstart)
            tu = tstart + tdif
            vu = Abs(timeangle(tu) - termang)
        End If
    Wend
    termtime = (tstart + tend) / 2#
End Function
Private Function solarterm(ByVal year As Long, ByRef jdpws As Double, ByRef vjdterms() As Double)
    Dim dstart As Long, dend As Long, month As Long, day As Long
    Dim angle As Double, offs As Double
    If (year < 1928) Then
        offs = (116# + 25# / 60#) / 360#
    Else
        offs = 120# / 360#
    End If
    'Determine the time of winter solstice of previous year
    dstart = Int(julian_date(year - 1, 12, 18, 12#))
    dend = Int(julian_date(year - 1, 12, 25, 12#))
    jdpws = termtime(CDbl(dstart), CDbl(dend), 0#) + offs
    ReDim vjdterms(24)
    For j = 0 To 23
        month = Int(j / 2) + 1
        day = (j Mod 2) * 14
        dstart = Int(julian_date(year, month, 1 + day, 12#))
        dend = Int(julian_date(year, month, 10 + day, 12#))
        angle = (j + 1) * 15#
        vjdterms(j) = termtime(CDbl(dstart), CDbl(dend), angle) + offs
    Next j
End Function
Private Function IsLeapYear(ByVal year As Long) As Boolean
    IsLeapYear = False
    If (Fix(year / 100) * 100 <> year) Then ' Non century year */
        If (Fix(year / 4) * 4 = year) Then IsLeapYear = True
    Else
       If (Fix(year / 400) * 400 = year) Then IsLeapYear = True
    End If
End Function
Private Function Number2MonthCH(ByVal month As Double, ByVal nstart As Long, ByVal ndays As Long) As String
  Number2MonthCH = ""
  nmonth = Int(month)
  If (month - nmonth = 0.5) Then Number2MonthCH = Number2MonthCH & "闰"
  If (nmonth = 10) Then Number2MonthCH = Number2MonthCH & "十": nmonth = 0
  If (nmonth = 11) Then Number2MonthCH = Number2MonthCH & "冬": nmonth = 0
  If (nmonth >= 12) Then Number2MonthCH = Number2MonthCH & "腊": nmonth = 0
  If (nmonth = 1 And Len(Number2MonthCH) = 0) Then
     Number2MonthCH = Number2MonthCH & "正"
  Else
     If nmonth > 0 Then Number2MonthCH = Number2MonthCH & miscchar(nmonth)
  End If
  Number2MonthCH = Number2MonthCH & "月"
  If ndays > 0 Then Number2MonthCH = Number2MonthCH & IIf(ndays > 29, "大", "小")
  If nstart > 0 Then Number2MonthCH = Number2MonthCH & nstart & "日始"
End Function
Private Function Number2DayCH(ByVal nday As Long) As String
    Number2DayCH = ""
    If (nday <= 10) Then Number2DayCH = Number2DayCH & miscchar(0)
    If (nday >= 30) Then Number2DayCH = Number2DayCH & miscchar(3): nday = nday - 20
    If (nday > 20 And nday < 30) Then Number2DayCH = Number2DayCH & miscchar(11): nday = nday - 20
    If (nday = 20) Then Number2DayCH = Number2DayCH & miscchar(2): nday = nday - 10
    If (nday > 10 And nday < 20) Then Number2DayCH = Number2DayCH & miscchar(10): nday = nday - 10
    Number2DayCH = Number2DayCH & miscchar(nday)
End Function
Function WuxingCH(ByVal cyear As Long) As String
    cyear = (cyear - 1984) Mod 60
    If (cyear < 0) Then cyear = cyear + 60
    WuxingCH = CHwuxing(Int(cyear / 2))
End Function
Private Function JiazhiCH(ByVal cyear As Long) As String
    cyear = (cyear - 1984) Mod 60
    If (cyear < 0) Then cyear = cyear + 60
    JiazhiCH = CHtiangan(cyear Mod 10) & CHdizhi(cyear Mod 12) & "(" & CHshengxiao(cyear Mod 12) & ")"
End Function
Function PrintMonth(ByVal year As Long, ByVal month As Long, ByRef Amonth() As String) As String
 On Error Resume Next
 PrintMonth = ""
 lmon = lunaryear(year, vterms, lastnew, lastmon, vmoons, vmonth, nextnew)
 daysinmonth(1) = IIf(IsLeapYear(year), 29, 28)
 ReDim Amonth(0)
 ' Set julian day counter to 1st of the month
 jdcnt = julian_date(year, month, 1, 12#)
  'Find julian day of the start of the next month
 If (month < 12) Then
     jdnext = julian_date(year, month + 1, 1, 12#)
 Else
     jdnext = julian_date(year + 1, 1, 1, 12#)
 End If
 Dim sameday As Boolean, termcnt As Long, moncnt As Long, ldcnt As Long, dcnt As Long
 termcnt = (month - 1) * 2
  ' Set lunar month counter to the 1st lunar month of the calendar month
 moncnt = 0
 Do While (moncnt <= UBound(vmoons) And vmoons(moncnt) < jdcnt)
    moncnt = moncnt + 1
 Loop
 
 
 'In case solarterm and 1st of lunar month falls on the same day
 'Header of the month
 Dim cmonth As Long, nstartlm As Long, cmonname As String
 nstartlm = CLng(vmoons(moncnt)) - jdcnt + 1
 Dim ndayslm As Long
 If (moncnt < UBound(vmoons) - LBound(vmoons)) Then
     ndayslm = Int(vmoons(moncnt + 1) - vmoons(moncnt))
 Else
     ndayslm = Int(nextnew - back(vmoons) + 1)
 End If
 cmonname = Number2MonthCH(vmonth(moncnt), nstartlm, ndayslm)
 
 PrintMonth = vbCrLf & "农历:"
 'January is special if lunar New Year is in February
 cmonth = Int(vmonth(moncnt))
 If (month = 1 And cmonth <> 1) Then
     PrintMonth = PrintMonth & JiazhiCH(year - 1) & "年" & cmonname
     If (vmoons(moncnt + 1) < jdnext) Then 'Two lunar months in one month
            Dim nstartlm1 As Long, ndayslm1 As Long, cmonname1 As String
            nstartlm1 = Int(vmoons(moncnt + 1) - jdcnt + 1)
            If (moncnt < UBound(vmoons) - LBound(vmoons) - 1) Then
                ndayslm1 = Int(vmoons(moncnt + 2) - vmoons(moncnt + 1))
            Else
                ndayslm1 = Int(nextnew - back(vmoons))
            End If
            cmonname1 = Number2MonthCH(vmonth(moncnt + 1), nstartlm1, ndayslm1)
            PrintMonth = PrintMonth & "," & JiazhiCH(year) & "年" & cmonname1
     End If
 Else
     tt = (moncnt < UBound(vmoons) - LBound(vmoons)): If tt Then tt = tt And vmoons(moncnt + 1) < jdnext
     If tt Then
        ' Two lunar months in one month
            nstartlm1 = Int(vmoons(moncnt + 1) - jdcnt + 1)
            If (moncnt < UBound(vmoons) - LBound(vmoons) - 1) Then
                ndayslm1 = Int(vmoons(moncnt + 2) - vmoons(moncnt + 1))
            Else
                ndayslm1 = Int(nextnew - back(vmoons))
            End If
            cmonname1 = Number2MonthCH(vmonth(moncnt + 1), nstartlm1, ndayslm1)
            PrintMonth = PrintMonth & JiazhiCH(year) & "年" & cmonname & "," & cmonname1
     Else
           If (month = 2 And vmoons(moncnt) >= jdnext) Then ' No new moon in February */
            ndayslm = Int(vmoons(moncnt) - vmoons(moncnt - 1))
            cmonname = Number2MonthCH(vmonth(moncnt - 1), nstartlm, ndayslm)
            If InStr(cmonname, "月") > 0 Then cmonname = Left(cmonname, InStr(cmonname, "月") + 1)
           End If
           PrintMonth = PrintMonth & JiazhiCH(year) & "年" & cmonname
     End If
 End If
 Amonth(0) = PrintMonth
 PrintMonth = PrintMonth & vbCrLf & vbCrLf
 'Day of week
 For i = 0 To 6
     PrintMonth = PrintMonth & "  " & daynamesCH(i) & "  "
 Next i
 PrintMonth = PrintMonth & " " & vbCrLf & vbCrLf
   
 sameday = False: dcnt = 1
 If (month <> 1) Then
     ldcnt = Int(jdcnt - vmoons(moncnt - 1) + 1)
 Else
     ldcnt = Int(jdcnt - lastnew + 1)
 End If
 If (jdcnt = vmoons(moncnt)) Then ldcnt = 1
 
 dofw = (Int(jdcnt) + 1) Mod 7
 'At most can be six weeks
    pre_mch = Int(vmonth(moncnt))
    For W = 0 To 5
        For i = 0 To 6
            jieqi = ""
            If (dcnt > daysinmonth(month - 1)) Then Exit For
            If (W = 0) Then
                If (i < dofw) Then PrintMonth = PrintMonth & Space(11): GoTo contiue
            End If
            PrintMonth = PrintMonth & "  " & Right("  " & dcnt, 2)
            If (jdcnt <> vterms(termcnt) And jdcnt <> vmoons(moncnt) And Not sameday) Then
                cmonname = Number2DayCH(ldcnt)
            ElseIf (sameday) Then
                cmonname = Number2MonthCH(vmonth(moncnt), 0, 0): pre_mch = Int(vmonth(moncnt)): nstartlm = nstartlm1: If moncnt < UBound(vmoons) Then moncnt = moncnt + 1
                sameday = False
            ElseIf (jdcnt = vterms(termcnt)) Then
                If (jdcnt = vmoons(moncnt)) Then sameday = True
                jieqi = CHjieqi(termcnt): termcnt = termcnt + 1: cmonname = jieqi
            Else
                cmonname = Number2MonthCH(vmonth(moncnt), 0, 0): pre_mch = Int(vmonth(moncnt)): If moncnt < UBound(vmoons) Then moncnt = moncnt + 1
            End If
            PrintMonth = PrintMonth & " " & cmonname & IIf(InStr(cmonname, "闰") > 0, "", "  ")
            y_ = IIf(month = 1 And pre_mch <> 1 Or pre_mch = 1 And dcnt < nstartlm, year - 1, year)
            m_ch = IIf(dcnt < nstartlm, IIf(pre_mch = 1, 12, pre_mch - 1), pre_mch)
            Call push_back(Amonth, year & "-" & month & "-" & dcnt & "," & daynamesCH(i) & "," & y_ & "-" & m_ch & "-" & ldcnt & " " & JiazhiCH(y_) & "年" & Number2MonthCH(CDbl(m_ch), 0, 0) & Number2DayCH(ldcnt) & IIf(jieqi <> "", " " & jieqi, ""))
            
            dcnt = dcnt + 1: jdcnt = jdcnt + 1
            If (jdcnt = vmoons(moncnt)) Then
                ldcnt = 1
            Else
                ldcnt = ldcnt + 1
            End If
contiue: Next i
         j = i
         For i = j To 6
             PrintMonth = PrintMonth & Space(11)
         Next i
         PrintMonth = PrintMonth & " " & vbCrLf
         If (dcnt > daysinmonth(month - 1)) Then Exit For
         PrintMonth = PrintMonth & vbCrLf
    Next W
    
End Function