VBA脚本参考
'Overall Correction by VBAdvisor on 7/July/2007
'I will keep update once I catch any more mistakes.
'1955-5-21 mistake is due to wrong initial value 457037C,change to 457137C
'1989-8-1 mistake is due to wrong initial value 93700CE,change to 95700CE
'2013-6-8 mistake is due to wrong initial value B5500D2,change to AD500D2
'1916-3-1 mistake is due to wrong initial value 56A00CC,change to D6A00CB
'1920-12-1 mistake is due to wrong initial value 49B00DC,change to 49700DC
'2025-5-1 mistake is due to wrong initial value 96E0681,change to A6E0681
'2033-9-1 mistake is due to wrong initial value 4AB0B83,change to 4AF0B83
'Lunar date 1915 has an invalid initial value B5500D6,change to B5400D6
'Lunar date 2065 has an invalid initial value DA400CD,change to DA500CD
'Lunar date 2068 has an invalid initial value A6C00CB,change to A6D00CB 2069-1-22
'Lunar date 2079-1-21 has an invalid initial value 52B00CA,change to 62B00CA
'Lunar date 2078 has an invalid initial value A5A00D4,change to A5B00D4
'农历常量(1899~2100，共202年）
Private Const LunarTable = "AB500D2,4BD0883," _
& "4AE00DB,A5700D0,54D0581,D2600D8,D9500CC,655147D,56A00D5,9AD00CA,55D027A,4AE00D2," _
& "A5B0682,A4D00DA,D2500CE,D25157E,B5400D6,D6A00CB,ADA027B,95B00D3,49717C9,49700DC," _
& "A4B00D0,B4B0580,6A500D8,6D400CD,AB5147C,2B600D5,95700CA,52F027B,49700D2,6560682," _
& "D4A00D9,EA500CE,6A9157E,5AD00D6,2B600CC,86E137C,92E00D3,C8D1783,C9500DB,D4A00D0," _
& "D8A167F,B5500D7,56A00CD,A5B147D,25D00D5,92D00CA,D2B027A,A9500D2,B550781,6CA00D9," _
& "B5500CE,535157F,4DA00D6,A5B00CB,457137C,52B00D4,A9A0883,E9500DA,6AA00D0,AEA0680," _
& "AB500D7,4B600CD,AAE047D,A5700D5,52600CA,F260379,D9500D1,5B50782,56A00D9,96D00CE," _
& "4DD057F,4AD00D7,A4D00CB,D4D047B,D2500D3,D550883,B5400DA,B6A00CF,95A1680,95B00D8," _
& "49B00CD,A97047D,A4B00D5,B270ACA,6A500DC,6D400D1,AF40681,AB600D9,95700CE,4AF057F," _
& "49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00D8,C9600CD," _
& "D95047C,D4A00D4,DA500C9,755027A,56A00D1,ABB0781,25D00DA,92D00CF,CAB057E,A9500D6," _
& "B4A00CB,BAA047B,AD500D2,55D0983,4BA00DB,A5B00D0,5171680,52B00D8,A9300CD,795047D," _
& "6AA00D4,AD500C9,5B5027A,4B600D2,A6E0681,A4E00D9,D2600CE,EA6057E,D5300D5,5AA00CB," _
& "76A037B,96D00D3,4AF0B83,4AD00DB,A4D00D0,D0B1680,D2500D7,D5200CC,DD4057C,B5A00D4," _
& "56D00C9,55B027A,49B00D2,A570782,A4B00D9,AA500CE,B25157E,6D200D6,ADA00CA,4B6137B," _
& "93700D3,49F08C9,49700DB,64B00D0,68A1680,EA500D7,6AA00CC,A6C147C,AAE00D4,92E00CA," _
& "D2E0379,C9600D1,D550781,D4A00D9,DA500CD,5D5057E,56A00D6,A6D00CB,55D047B,52D00D3," _
& "A9B0883,A9500DB,B4A00CF,B6A067F,AD500D7,55A00CD,ABA047C,A5B00D4,62B00CA,B27037A," _
& "69300D1,7330781,6AA00D9,AD500CE,4B5157E,4B600D6,A5700CB,54E047C,D1600D2,E960882," _
& "D5200DA,DAA00CF,6AA167F,56D00D7,4AE00CD,A9D047D,A2D00D4,D1500C9,F250279,D5200D1"
AutoHotkey移植公历转农历函数代码如下(作者：海盗)：
/*
公历转农历：
输入公历，输出农历
农历（天干地支属相日期）:=Date_GetLunarDate(公历日期 YYYYMMDD)
*/
Date_GetLunarDate(Gregorian)
{
;1899年~2100年农历数据
;前三位，Hex，转Bin，表示当年月份，1为大月，0为小月
;第四位，Dec，表示闰月天数，1为大月30天，0为小月29天
;第五位，Hex，转Dec，表示是否闰月，0为不闰，否则为闰月月份
;倒数第三位是农历闰几月，直接读取。
;倒数第四位也即正数第四位，是闰月天数,1为大 30天， 0为小29天。
;举例2017年的5171680的前3位517,转成二进制010100010111,表示当年1-12月大小情况。第5位6，第4位1 表示2017年闰六月 大。
;测试用例：20170920 输出八月初一
;测试用例：20330828 输出八月初四
;农历常量(1899~2100，共202年）
;I will keep update once I catch any more mistakes.
;1955-5-21 mistake is due to wrong initial value 457037C,change to 457137C
;1989-8-1 mistake is due to wrong initial value 93700CE,change to 95700CE
;2013-6-8 mistake is due to wrong initial value B5500D2,change to AD500D2
;1916-3-1 mistake is due to wrong initial value 56A00CC,change to D6A00CB
;1920-12-1 mistake is due to wrong initial value 49B00DC,change to 49700DC
;2025-5-1 mistake is due to wrong initial value 96E0681,change to A6E0681
;2033-9-1 mistake is due to wrong initial value 4AB0B83,change to 4AF0B83
;Lunar date 1915 has an invalid initial value B5500D6,change to B5400D6
;Lunar date 2065 has an invalid initial value DA400CD,change to DA500CD
;Lunar date 2068 has an invalid initial value A6C00CB,change to A6D00CB 2069-1-22
;Lunar date 2079-1-21 has an invalid initial value 52B00CA,change to 62B00CA
;Lunar date 2078 has an invalid initial value A5A00D4,change to A5B00D4
LunarData=
(LTrim Join
AB500D2,4BD0883,
4AE00DB,A5700D0,54D0581,D2600D8,D9500CC,655147D,56A00D5,9AD00CA,55D027A,4AE00D2,
A5B0682,A4D00DA,D2500CE,D25157E,B5400D6,D6A00CB,ADA027B,95B00D3,49717C9,49700DC,
A4B00D0,B4B0580,6A500D8,6D400CD,AB5147C,2B600D5,95700CA,52F027B,49700D2,6560682,
D4A00D9,EA500CE,6A9157E,5AD00D6,2B600CC,86E137C,92E00D3,C8D1783,C9500DB,D4A00D0,
D8A167F,B5500D7,56A00CD,A5B147D,25D00D5,92D00CA,D2B027A,A9500D2,B550781,6CA00D9,
B5500CE,535157F,4DA00D6,A5B00CB,457137C,52B00D4,A9A0883,E9500DA,6AA00D0,AEA0680,
AB500D7,4B600CD,AAE047D,A5700D5,52600CA,F260379,D9500D1,5B50782,56A00D9,96D00CE,
4DD057F,4AD00D7,A4D00CB,D4D047B,D2500D3,D550883,B5400DA,B6A00CF,95A1680,95B00D8,
49B00CD,A97047D,A4B00D5,B270ACA,6A500DC,6D400D1,AF40681,AB600D9,95700CE,4AF057F,
49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00D8,C9600CD,
D95047C,D4A00D4,DA500C9,755027A,56A00D1,ABB0781,25D00DA,92D00CF,CAB057E,A9500D6,
B4A00CB,BAA047B,AD500D2,55D0983,4BA00DB,A5B00D0,5171680,52B00D8,A9300CD,795047D,
6AA00D4,AD500C9,5B5027A,4B600D2,A6E0681,A4E00D9,D2600CE,EA6057E,D5300D5,5AA00CB,
76A037B,96D00D3,4AF0B83,4AD00DB,A4D00D0,D0B1680,D2500D7,D5200CC,DD4057C,B5A00D4,
56D00C9,55B027A,49B00D2,A570782,A4B00D9,AA500CE,B25157E,6D200D6,ADA00CA,4B6137B,
93700D3,49F08C9,49700DB,64B00D0,68A1680,EA500D7,6AA00CC,A6C147C,AAE00D4,92E00CA,
D2E0379,C9600D1,D550781,D4A00D9,DA500CD,5D5057E,56A00D6,A6D00CB,55D047B,52D00D3,
A9B0883,A9500DB,B4A00CF,B6A067F,AD500D7,55A00CD,ABA047C,A5B00D4,62B00CA,B27037A,
69300D1,7330781,6AA00D9,AD500CE,4B5157E,4B600D6,A5700CB,54E047C,D1600D2,E960882,
D5200DA,DAA00CF,6AA167F,56D00D7,4AE00CD,A9D047D,A2D00D4,D1500C9,F250279,D5200D1
)
;分解公历年月日
StringLeft,Year,Gregorian,4
StringMid,Month,Gregorian,5,2
StringRight,Day,Gregorian,2
if (Year>2100 Or Year<1900)
{
errorinfo=无效日期
return,errorinfo
}
;获取两年内的农历数据
Pos:=(Year-1900)*8+1
StringMid,Data0,LunarData,%Pos%,7
Pos+=8
StringMid,Data1,LunarData,%Pos%,7
;判断农历年份
Analyze(Data1,MonthInfo,LeapInfo,Leap,Newyear)
Date1=%Year%%Newyear%
Date2:=Gregorian
EnvSub,Date2,%Date1%,Days
If Date2<0 ;和当年农历新年相差的天数
{
Analyze(Data0,MonthInfo,LeapInfo,Leap,Newyear)
Year-=1
Date1=%Year%%Newyear%
Date2:=Gregorian
EnvSub,Date2,%Date1%,Days
}
;计算农历日期
Date2+=1
LYear:=Year ;农历年份，就是上面计算后的值
if Leap ;有闰月
{
StringLeft,p1,MonthInfo,%Leap%
StringTrimLeft,p2,MonthInfo,%Leap%
thisMonthInfo:=p1 . LeapInfo . p2
}
Else
thisMonthInfo:=MonthInfo
loop,13
{
StringMid,thisMonth,thisMonthInfo,%A_index%,1
thisDays:=29+thisMonth
if Date2>%thisDays%
Date2:=Date2-thisDays
Else
{
if leap
{
If leap>%a_index%
LMonth:=A_index
Else
LMonth:=A_index-1
}
Else
LMonth:=A_index
LDay:=Date2
Break
}
}
LDate=%LYear%年%LMonth%月%LDay% ;完成
;转换成习惯性叫法
Tiangan=甲,乙,丙,丁,戊,已,庚,辛,壬,癸
Dizhi=子,丑,寅,卯,辰,巳,午,未,申,酉,戌,亥
Shengxiao=鼠,牛,虎,兔,龙,蛇,马,羊,猴,鸡,狗,猪
loop,Parse,Tiangan,`,
Tiangan%a_index%:=A_LoopField
loop,Parse,Dizhi,`,
Dizhi%a_index%:=A_LoopField
loop,Parse,Shengxiao,`,
Shengxiao%a_index%:=A_LoopField
Order1:=Mod((LYear-4),10)+1
Order2:=Mod((LYear-4),12)+1
LYear:=Tiangan%Order1% . Dizhi%Order2% . "(" . Shengxiao%Order2% . ")"
_monthStr=正,二,三,四,五,六,七,八,九,十,冬,腊
loop,Parse,_monthStr,`,
_monthStr%A_index%:=A_LoopField
LMonth:=_monthStr%LMonth%
_dayStr=初一,初二,初三,初四,初五,初六,初七,初八,初九,初十,十一,十二,十三,十四,十五,十六,十七,十八,十九,二十,廿一,廿二,廿三,廿四,廿五,廿六,廿七,廿八,廿九,三十
loop,Parse,_dayStr,`,
_dayStr%A_index%:=A_LoopField
LDay:=_dayStr%LDay%
LDate=%LYear%年%LMonth%月%LDay%
Return,LDate
}
;分析农历数据的函数 按上面所示规则分析
;4个回参分别对应四项
Analyze(Data,ByRef rtn1,ByRef rtn2,ByRef rtn3,ByRef rtn4)
{
;rtn1
StringLeft,Month,Data,3
rtn1:=ToBase("0x" . Month,2)
;517返回10100010111但期望010100010111
;~ 补足12位的做法：
rtn1:=SubStr("000000000000" . rtn1, -11)
;rtn2
StringMid,rtn2,Data,4,1
;rtn3
StringMid,leap,Data,5,1
rtn3:=leap<10?leap:ToBase("0x" . leap,10)
;rtn4
StringRight,Newyear,Data,2
rtn4:=ToBase("0x" . newyear,10)
rtn4:=SubStr("0000" . rtn4,-3)
}
;进制转换
;第一个参数输入数字，0x开头为16进制，无前缀为10进制
;第二个参数是 目的进制
ToBase(n,b){
return (n < b ? "" : ToBase(n//b,b)) . ((d:=Mod(n,b)) < 10 ? d : Chr(d+55))
}
扫一扫
1563
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
