公历农历相关计算

lss001

Sub auto_Open() 'Excel底部状态栏显示公历农历(1900-2100)

   Dim a, b, c, e, f, g, h, i, j, k, m, n, p, q, r, s, t, u, v, x, y, s1,s2, s3, s4, e1, e2, e3, e4, r1, r2, _

        j1, j2, jj, gq, nq, gj, nj, jr, js, jt, jz, jx, zn, zy, zr, zs, rq, t1,t2, t3, t4, f1, f2, f3, f4, am, rm, cm

   Set js = CreateObject("scriptcontrol"): js.Language ="jscript": gq = Date '*****

    s = "var nf=new Array(" & _

   "0x04bd8,0x04ae0,0x0a570,0x054d5,0x0d260,0x0d950,0x16554,0x056a0,0x09ad0,0x055d2,"& _

   "0x04ae0,0x0a5b6,0x0a4d0,0x0d250,0x1d255,0x0b540,0x0d6a0,0x0ada2,0x095b0,0x14977,"& _

   "0x04970,0x0a4b0,0x0b4b5,0x06a50,0x06d40,0x1ab54,0x02b60,0x09570,0x052f2,0x04970,"& _

   "0x06566,0x0d4a0,0x0ea50,0x06e95,0x05ad0,0x02b60,0x186e3,0x092e0,0x1c8d7,0x0c950,"& _

   "0x0d4a0,0x1d8a6,0x0b550,0x056a0,0x1a5b4,0x025d0,0x092d0,0x0d2b2,0x0a950,0x0b557,"& _

   "0x06ca0,0x0b550,0x15355,0x04da0,0x0a5b0,0x14573,0x052b0,0x0a9a8,0x0e950,0x06aa0,"& _

   "0x0aea6,0x0ab50,0x04b60,0x0aae4,0x0a570,0x05260,0x0f263,0x0d950,0x05b57,0x056a0,"& _

   "0x096d0,0x04dd5,0x04ad0,0x0a4d0,0x0d4d4,0x0d250,0x0d558,0x0b540,0x0b6a0,0x195a6,"& _

   "0x095b0,0x049b0,0x0a974,0x0a4b0,0x0b27a,0x06a50,0x06d40,0x0af46,0x0ab60,0x09570,"& _

   "0x04af5,0x04970,0x064b0,0x074a3,0x0ea50,0x06b58,0x055c0,0x0ab60,0x096d5,0x092e0,"& _

   "0x0c960,0x0d954,0x0d4a0,0x0da50,0x07552,0x056a0,0x0abb7,0x025d0,0x092d0,0x0cab5,"& _

   "0x0a950,0x0b4a0,0x0baa4,0x0ad50,0x055d9,0x04ba0,0x0a5b0,0x15176,0x052b0,0x0a930,"& _

   "0x07954,0x06aa0,0x0ad50,0x05b52,0x04b60,0x0a6e6,0x0a4e0,0x0d260,0x0ea65,0x0d530,"& _

   "0x05aa0,0x076a3,0x096d0,0x04afb,0x04ad0,0x0a4d0,0x1d0b6,0x0d250,0x0d520,0x0dd45,"& _

   "0x0b5a0,0x056d0,0x055b2,0x049b0,0x0a577,0x0a4b0,0x0aa50,0x1b255,0x06d20,0x0ada0,"& _

   "0x14b63,0x09370,0x049f8,0x04970,0x064b0,0x168a6,0x0ea50,0x06b20,0x1a6c4,0x0aae0,"& _

   "0x0a2e0,0x0d2e3,0x0c960,0x0d557,0x0d4a0,0x0da50,0x05d55,0x056a0,0x0a6d0,0x055d4,"& _

   "0x052d0,0x0a9b8,0x0a950,0x0b4a0,0x0b6a6,0x0ad50,0x055a0,0x0aba4,0x0a5b0,0x052b0,"& _

   "0x0b273,0x06930,0x07337,0x06aa0,0x0ad50,0x14b55,0x04b60,0x0a570,0x054e4,0x0d160,"& _

   "0x0e968,0x0d520,0x0daa0,0x16aa6,0x056d0,0x04ae0,0x0a9d4,0x0a2d0,0x0d150,0x0f252,0x0d520);"& _

   "var j,r,de=new nDate(new Date(""" & gq &"""));" '农历数据

    s = s & "function m(y){return(nf[y-1900]&0xf)};" '返回农历y年闰月1-12/没闰返回 0

    s = s & "functionmd(y,m){return((nf[y-1900]&(0x10000>>m))?30:29)};r=md(de.year,de.month);"'返回农历y年m月的天数

    s = s & "functionxd(y){if(m(y))return((nf[y-1900]&0x10000)?30:29);else return(0)};" '返回农历y年闰月的天数

    s = s & "function yd(y){var i,s=348;for(i=0x8000;i>0x8;i>>=1)s+=(nf[y-1900]&i)?1:0;return(s+xd(y))};"'返回农历y年的总天数

    s = s & "function nDate(n){var i,p=0,t=0," & _

   "f=(Date.UTC(n.getFullYear(),n.getMonth(),n.getDate())-Date.UTC(1900,0,31))/864e5;"& _

   "for(i=1900;i<2100&&f>0;i++){t=yd(i);f-=t;}"& _

   "if(f<0){f+=t;i--;}this.year=i;p=m(i);this.sp=false;" &_

   "for(i=1;i<13&&f>0;i++){if(p>0&&i==(p+1)&&this.sp==false)"& _

   "{--i;this.sp=true;t=xd(this.year);}else{t=md(this.year,i);}"& _

   "if(this.sp==true&&i==(p+1))this.sp=false;f-=t;}"& _

   "if(f==0&&p>0&&i==p+1)if(this.sp){this.sp=false;}else{this.sp=true;--i;}"& _

   "if(f<0){f+=t;--i;}this.month=i;this.j=this.sp;this.day=f+1;};"& _

   "y=de.year;m=de.month;d=de.day;j=de.j;y+'-'+m+'-'+d+'>'+r+'<'+j"'返回农历日期/闰月数据

    h = js.Eval(s): k = IIf(Mid(h, InStrRev(h, "<") + 1, 5) ="true", "闰", "")

   nq = Format(Left(h, InStr(1, h, ">") - 1), "yyyy/mm/dd")

   

   jr = Split("小寒,大寒,立春,雨水,惊蛰,春分,清明,谷雨,立夏,小满,芒种,夏至," & _

         "小暑,大暑,立秋,处暑,白露,秋分,寒露,霜降,立冬,小雪,大雪,冬至", ",")

   jt = Split("0,21208,42467,63836,85337,107014,128867,150921,173149,195551,218072,240693,"& _

        "263343,285989,308563,331033,353350,375494,397447,419210,440795,462224,483532,504758",",")

   js.addcode "function jq(r,s){var d=new Date((31556925974.7*(r-1900)+s*60000)+Date.UTC(1900,0,6,2,5));return(d.getUTCDate())}"

   ReDim jz(0 To 23)

   For i = 0 To 23 '返回某年的第n个节气为几日/从0小寒算起

       r = js.Run("jq", Year(gq), jt(i))

       If i < 18 Then jz(i) = "0" & (i + 2) \ 2 Else jz(i) =(i + 2) \ 2

       If r < 10 Then jz(i) = Year(gq) & "/" & jz(i) &"/" & "0" & r Else jz(i) = Year(gq) &"/" & jz(i) & "/" & r

   Next

   For i = 0 To Month(gq) * 2 - 1 '//节气

       If gq = CDate(jz(i)) Then a = jr(i): Exit For

   Next

   

   gj = Split("0101元旦,0308妇女节,0312植树节,0501劳动节,0504青年节,0512护士节,0601儿童节,0701建党节,0801建军节,0910教师节,1001国庆节", ",")

   For i = 0 To UBound(gj) '//公历节日

        If Format(gq, "mmdd") = Left(gj(i), 4) Then b = Mid(gj(i), 5,3): Exit For

   Next

  

补充内容 (2020-3-9 19:43):
'节气显示修改如下：
For I = Month(gq) * 2 - 1 To 0 Step -1 '//节气
        If gq >= CDate(jz(I)) Then
            a = jr(I): Exit For
        End If
    Next
    If a = "" Then a = jr(23)

lss001

  
    p = Split("正,二,三,四,五,六,七,八,九,十,十一,十二", ",") '农历月份名
    q = Split("初一,初二,初三,初四,初五,初六,初七,初八,初九,初十,十一,十二,十三,十四,十五" & _
             ",十六,十七,十八,十九,二十,廿一,廿二,廿三,廿四,廿五,廿六,廿七,廿八,廿九,三十", ",") '农历日期名
    n = Evaluate("NUMBERSTRING(""" & Year(nq) & """,3)") & "年" & k & p(Month(nq) - 1) & "月" & q(Day(nq) - 1)
    nj = Split("0101春节,0115元宵节,0202龙头节,0303上巳节,0505端午节,0707七夕节,0715中元节,0815中秋节,0909重阳节,1208腊八节,1223小年,12xx除夕", ",")
    For i = 0 To UBound(nj)  '//农历节日
        m = Mid(h, InStr(1, h, ">") + 1, 2)
        If i = UBound(nj) And Month(nq) = 12 And Day(nq) = m Then c = Mid(nj(i), 5, 3): Exit For '除夕
        If Format(nq, "mmdd") = Left(nj(i), 4) Then c = Mid(nj(i), 5, 3): Exit For
    Next
   
    '//以下天干地支参考公历1900/1/1己亥(猪)年丙子月甲戌日甲子时为标准！
    e = Split("甲,乙,丙,丁,戊,己,庚,辛,壬,癸", ",") '天干名称
    f = Split("子,丑,寅,卯,辰,巳,午,未,申,酉,戌,亥", ",") '地支名称
    g = Split("鼠,牛,虎,兔,龙,蛇,马,羊,猴,鸡,狗,猪", ",") '属相名称
    zn = e((Year(nq) + 6) Mod 10) & f((Year(nq) + 8) Mod 12) & "(" & g((Year(nq) + 8) Mod 12) & ")年" '干支年
    u = DateDiff("m", #1/1/1900#, gq)
    y = e((u + 3) Mod 10) & f((u + 1) Mod 12)
    z = e((u + 2) Mod 10) & f(u Mod 12)
    For i = 0 To Month(gq) * 2 - 1 Step 2: zy = IIf(gq >= CDate(jz(i)), y, z) & "月": Next '干支月
    zr = e((gq - #1/1/1900#) Mod 10) & f((gq - #1/1/1900# + 10) Mod 12) & "日" '干支日
    x = ((gq - #1/1/1900#) * 12 + Int((Hour(Now) + 1) / 2))
    zs = e(x Mod 10) & f(x Mod 12) & "时" '干支时
   
    f1 = Mid(jz(11), 1, 2): f2 = Mid(jz(11), 3, 2)
    f3 = Month(CDate(jz(11))): f4 = Day(CDate(jz(11)))
    v = 7 - ((4 * f1 + Int(f1 / 4) + 5 * f2 + Int(f2 / 4) + Int(3 * (f3 + 1) / 5) + f4 - 3) Mod 10)
    e1 = CDate(jz(11)) + IIf(v >= 0, v, v + 10) + 20: e2 = e1 + 10
    If e2 > jz(14) Then e3 = e2 + 10 Else e3 = e2 + 20
    If gq = e1 Then e4 = "初伏" '初伏/夏至后(不含夏至)第三个庚日
    If gq = e2 Then e4 = "中伏" '中伏/夏至后(不含夏至)第四个庚日
    If gq = e3 Then e4 = "末伏" '末伏/立秋后(不含立秋)第一个庚日
   
    m1 = 7 - ((Year(gq) Mod 2) * 5 + Int(Mid(Year(gq), 2, 2) / 4) Mod 10)
    n1 = CDate(Year(gq) & "/6/" & m1)
    m2 = Year(gq) & "/7/" & 12 - ((m1 * 5 + Int(m1 / 4)) Mod 12)
    If CDate(m2) > CDate(jz(12)) Then n2 = CDate(m2) Else n2 = CDate(m2) + 12
    If gq = n1 Then n3 = "入梅" '入梅/芒种起第一个丙日
    If gq = n2 Then n3 = "出梅" '出梅/小暑起第一个未日
   
    j1 = CDate(Year(gq) - 1 & "/12/" & js.Run("jq", Year(gq) - 1, jt(23)))
    For i = 0 To 81 Step 9 '冬九/冬至起
        If Month(gq) = 12 Then j2 = CDate(jz(23)) + i Else j2 = j1 + i
        j = j + 1: If gq = j2 Then jj = Evaluate("NUMBERSTRING(""" & j & 9 & """,3)")
        If j2 >= gq Then Exit For
    Next
   
    t1 = 115.9: t4 = 40.4: t2 = 8: t3 = gq - DateSerial(Year(gq), 1, 1 - 1) '北京延庆//经度/纬度/时区/期序
    s1 = Evaluate("(180+""" & t2 & """*15-""" & t1 & """-Acos(Tan(10547*pi()/81000*" & _
        "Cos(2*pi()*(""" & t2 & """+9)/365))*Tan(""" & t4 & """*pi()/180))*180/pi())/15")
    s2 = Evaluate("(180+""" & t2 & """*15-""" & t1 & """+Acos(Tan(10547*pi()/81000*" & _
        "Cos(2*pi()*(""" & t3 & """+9)/365))*Tan(""" & t4 & """*pi()/180))*180/pi())/15")
    s3 = "日出:" & Int(s1) & ":" & Int((s1 - Int(s1)) * 60) '理论日出
    s4 = "日落:" & Int(s2) & ":" & Int((s2 - Int(s2)) * 60) '理论日落
   
    Set jx = CreateObject("Microsoft.XMLHTTP")
       jx.Open "GET", "http://flash.weather.com.cn/wmaps/xml/beijing.xml", False '北京/beijing
       jx.Send
    If jx.Status = 200 Then
        r1 = jx.responsetext: r1 = Split(r1, "<"): r1 = Split(r1(2), """") '延庆/2
        r2 = r1(5) & "天气:" & r1(17) & "  气温:" & r1(19) & "℃~" & r1(21) & "℃ 风力:" & r1(25)
        Else: MsgBox "获取天气数据失败！"
    End If
   
    Application.StatusBar = Now & Format(gq, "aaaa ") & "/第" & Application.WeekNum(gq) & "周" & a & " " & b & _
    "/农历:" & n & "/" & zn & zy & zr & zs & "/" & c & e4 & n3 & jj & "/" & s3 & " " & s4 & "/" & r2 & "/"
End Sub

补充内容 (2020-3-19 19:50):
    s3 = "日出:" & Int(s1) & ":" & Int((s1 - Int(s1)) * 60) '理论日出
    s4 = "日落:" & Int(s2) & ":" & Int((s2 - Int(s2)) * 60) '理论日落
更改为：
    s3 = Int((s1 - Int(s1)) * 60)
    s4 = Int((s2 - Int(s2)) * 60)
    If s3 > 9 Then s3 = s3 Else s3 = "0" & s3
    If s4 > 9 Then s4 = s4 Else s4 = "0" & s4
    s3 = "日出:" & Int(s1) & ":" & s3 '理论日出
    s4 = "日落:" & Int(s2) & ":" & s4 '理论日落

micch

楼主是分享吧，看着代码就发憷，望而生畏，写代码真是太辛苦了