公历农历相关计算

lss001 · 发表于 2020-1-23 19:49

本帖最后由 lss001 于 2020-1-23 20:34 编辑

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

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

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

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

补充内容 (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 · 发表于 2020-1-23 19:50

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 · 发表于 2020-1-24 11:59

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

lss001 · 发表于 2024-7-15 22:01

本帖最后由 lss001 于 2024-7-16 06:55 编辑

lss001 发表于 2020-1-23 19:50
p = Split("正,二,三,四,五,六,七,八,九,十,十一,十二", ",") '农历月份名
q = Split("初一, ...

公农历更新附件！
…………………………～～～～～～～

hxj119 · 发表于 2024-7-15 22:18

十分感谢分享，看着这一堆代码蒙了的路过。。。

lss001 · 发表于 2024-7-15 22:33

本帖最后由 lss001 于 2024-8-4 14:31 编辑

..............................

fanion · 发表于 2024-7-15 22:59

感谢楼主更新代码并无私分享，谢谢！

		自动登录	找回密码
密码			免费注册

[分享] 公历农历相关计算