'##########################################################
'Class Nongligongli 用于农历与公历间的相互转换
'本类可处理1950-2010年之间的阴阳历转换
'如需更多年份，请参照已有农历信息自动扩充
'本类不输出错误信息，如输出结果为1900-1-1则意味发生错误。
'编写：冬雷 http://www.prowt.com sc200@126.com
'日期：2006-11-16
'版权：可自由传播，请保留所有版权及注释信息
'应用示例：
' Dim Nong
' Set Nong = New Nongligongli
' Response.Write Nong.gtoc("1984-12-10")&"
"
' Response.Write Nong.ctog("1984-10-18",1)&"
"
'##########################################################
Class Nongligongli '定义全局变量
dim ml(12)
dim nm(100)
dim i '初始化数据
Sub Class_Initialize()
'-----------------------------------------------
'定义公历月份天数
ml(0)=31
ml(1)=28
ml(2)=31
ml(3)=30
ml(4)=31
ml(5)=30
ml(6)=31
ml(7)=31
ml(8)=30
ml(9)=31
ml(10)=30
ml(11)=31 '定义农历数据
nm(0)="0,0217,0318,0417,0517,0615,0715,0814,0912,1011,1110,1209,1308"
nm(1)="0,0206,0308,0406,0506,0605,0704,0803,0901,1001,1030,1129,1228"
nm(2)="5,0127,0225,0326,0424,0524,0622,0722,0820,0919,1019,1117,1217,1315"
nm(3)="0,0214,0315,0414,0513,0611,0711,0810,0908,1008,1107,1206,1305"
nm(4)="0,0203,0305,0403,0503,0601,0630,0730,0828,0927,1027,1125,1225"
nm(5)="3,0124,0222,0324,0422,0522,0620,0719,0818,0916,1016,1114,1214,1313"
nm(6)="0,0212,0312,0411,0510,0609,0708,0806,0905,1004,1103,1202,1301"
nm(7)="8,0131,0302,0331,0430,0529,0628,0727,0825,0924,1023,1122,1221,1320"
nm(8)="0,0218,0320,0419,0519,0617,0717,0815,0913,1013,1111,1211,1309"
nm(9)="0,0208,0309,0408,0508,0606,0706,0804,0903,1002,1101,1130,1230"
nm(10)="6,0128,0227,0327,0426,0525,0624,0724,0822,0921,1020,1119,1218,1317"
nm(11)="0,0215,0317,0415,0515,0613,0713,0811,0910,1010,1108,1208,1306"
nm(12)="0,0205,0306,0405,0504,0602,0702,0731,0830,0929,1028,1127,1227"
nm(13)="4,0125,0224,0325,0424,0523,0621,0721,0819,0918,1017,1116,1216,1315"
nm(14)="0,0213,0314,0412,0512,0610,0709,0808,0906,1006,1104,1204,1303"
nm(15)="0,0202,0303,0402,0501,0531,0629,0728,0827,0925,1024,1123,1223"
nm(16)="3,0121,0220,0322,0421,0520,0619,0718,0816,0915,1014,1112,1212,1311"
nm(17)="0,0209,0311,0410,0509,0608,0708,0806,0904,1004,1102,1202,1231"
nm(18)="7,0130,0228,0329,0427,0527,0626,0725,0824,0922,1022,1120,1220,1318"
nm(19)="0,0217,0318,0417,0516,0615,0714,0813,0912,1011,1110,1209,1308"
nm(20)="0,0206,0308,0406,0505,0604,0703,0802,0901,0930,1030,1129,1228"
nm(21)="5,0127,0225,0327,0425,0524,0623,0722,0821,0919,1019,1118,1218,1316"
nm(22)="0,0215,0315,0414,0513,0611,0711,0809,0908,1007,1106,1206,1304"
nm(23)="0,0203,0305,0403,0503,0601,0630,0730,0828,0926,1026,1125,1224"
nm(24)="4,0123,0222,0324,0422,0522,0620,0719,0818,0916,1015,1114,1214,1312"
nm(25)="0,0211,0313,0412,0511,0610,0709,0807,0906,1005,1103,1203,1301"
nm(26)="8,0131,0301,0331,0429,0529,0627,0727,0825,0924,1023,1121,1221,1319"
nm(27)="0,0218,0320,0418,0518,0617,0716,0815,0913,1013,1111,1211,1309"
nm(28)="0,0207,0309,0407,0507,0606,0705,0804,0903,1002,1101,1130,1230"
nm(29)="6,0128,0227,0328,0426,0526,0624,0724,0823,0921,1021,1120,1219,1318"
nm(30)="0,0216,0317,0415,0514,0613,0712,0811,0909,1009,1108,1207,1306"
nm(31)="0,0205,0306,0405,0504,0602,0702,0731,0829,0928,1028,1126,1226"
nm(32)="4,0125,0224,0325,0424,0523,0621,0721,0819,0917,1017,1115,1215,1314"
nm(33)="0,0213,0315,0413,0513,0611,0710,0809,0907,1006,1105,1204,1303"
nm(34)="10,0202,0303,0401,0501,0531,0629,0728,0827,0925,1024,1123,1222,1321"
nm(35)="0,0220,0321,0420,0520,0618,0718,0816,0915,1014,1112,1212,1310"
nm(36)="0,0209,0310,0409,0509,0607,0707,0806,0904,1004,1102,1202,1231"
nm(37)="6,0129,0228,0329,0428,0527,0626,0726,0824,0923,1023,1121,1221,1319"
nm(38)="0,0217,0318,0416,0516,0614,0714,0812,0911,1011,1109,1209,1308"
nm(39)="0,0206,0308,0406,0505,0604,0703,0802,0831,0930,1029,1128,1228"
nm(40)="5,0127,0225,0327,0425,0524,0623,0722,0820,0919,1018,1117,1217,1316"
nm(41)="0,0215,0316,0415,0514,0612,0712,0810,0908,1008,1106,1206,1305"
nm(42)="0,0204,0304,0403,0503,0601,0630,0730,0828,0926,1026,1124,1224"
nm(43)="3,0123,0221,0323,0422,0521,0620,0719,0818,0916,1015,1114,1213,1312"
nm(44)="0,0210,0312,0411,0511,0609,0709,0807,0906,1005,1103,1203,1301"
nm(45)="8,0131,0301,0331,0430,0529,0628,0727,0826,0925,1024,1122,1222,1320"
nm(46)="0,0219,0319,0418,0517,0616,0716,0814,0913,1012,1111,1211,1309"
nm(47)="0,0207,0309,0407,0507,0605,0705,0803,0902,1002,1031,1130,1230"
nm(48)="5,0128,0227,0328,0426,0526,0624,0723,0822,0921,1020,1119,1219,1317"
nm(49)="0,0216,0318,0416,0515,0614,0713,0811,0910,1009,1108,1208,1307"
nm(50)="0,0205,0306,0405,0504,0602,0702,0731,0829,0928,1027,1126,1226"
nm(51)="4,0124,0223,0325,0423,0523,0621,0721,0819,0917,1017,1115,1215,1313"
nm(52)="0,0212,0314,0413,0512,0611,0710,0809,0907,1006,1105,1204,1303"
nm(53)="0,0201,0303,0402,0501,0531,0630,0729,0828,0926,1025,1124,1223"
nm(54)="2,0122,0220,0321,0419,0519,0618,0717,0816,0914,1014,1112,1212,1310"
nm(55)="0,0209,0310,0409,0508,0607,0706,0805,0904,1003,1102,1201,1231"
nm(56)="7,0129,0228,0329,0428,0527,0626,0725,0824,0922,1022,1121,1220,1319"
nm(57)="0,0218,0319,0417,0517,0615,0714,0813,0911,1011,1110,1210,1308"
nm(58)="0,0207,0308,0406,0505,0604,0703,0801,0831,0929,1029,1128,1227"
nm(59)="5,0126,0225,0327,0425,0524,0623,0722,0820,0919,1018,1117,1216,1315"
nm(60)="0,0214,0316,0414,0514,0612,0712,0810,0908,1008,1106,1206,1304"
End sub '################################################
'辅助方法 length
'根据年月求得公历该月的天数
'y：年份，四位整型
'm：月份，整型
'################################################
Public Function length(y,m)
if m=2 and ((y mod 400 =0) or (y mod 4 =0 and y mod 100 <> 0)) then
length=29
else
length=ml((m+1) mod 12)
end if
End Function '################################################
'主要方法 ctog
'农历转公历主函数
'cdate：农历日期，标准日期格式
'r：闰月标志，1为闰月，其它值为非闰月
'################################################
Public Function ctog(cdate,r)
dim y,m,d,yd,outy,outm,outd
y=year(cdate)
m=month(cdate)
d=day(cdate)
yd=split(nm(y-1950),",")
if r=1 and m<> cint(yd(0)) then
ctog="1900-1-1"
exit Function
end if
if (r=1 and m=cint(yd(0))) or (cint(yd(0))>0 and m>cint(yd(0))) then m=m+1
outm=int(left(yd(m),2))
outd=int(right(yd(m),2))+d-1
if outd>length(y,outm) then
outd=outd-length(y,outm)
outm=outm+1
end if
outy=y
if outm>12 then
outm=outm-12
outy=outy+1
end if
ctog=datevalue(outy&"-"&outm&"-"&outd)
End Function '################################################
'主要方法 gtoc
'公历转农历主函数
'gdate：公历日期，标准日期格式
'##注意：本函数输出为带汉字字符串，非标准日期格式
'################################################
Public Function gtoc(gdate)
dim y,m,d,yd,outy,outm,outd,sd,r
y=year(gdate)
m=month(gdate)
d=day(gdate)
if d>length(y,m) then
gtoc="1900-1-1"
exit Function
end if
yd=split(nm(y-1950),",")
sd=cstr(d)
if len(sd)<2 then sd="0"&sd
sd=cstr(m)&sd
if len(sd)<4 then sd="0"&sd
for i=0 to 12
if i+1<=ubound(yd) then
if cint(yd(i+1))>cint(sd) or i=ubound(yd) then exit for
else
exit for
end if
next
if i=0 then
if y-1950=0 then
gtoc="1900-1-1"
exit Function
end if
y=y-1
yd=split(nm(y-1950),",")
i=ubound(yd)
sd=cstr(cint(sd)+1200)
if cint(yd(i))>cint(sd) then i=i-1
end if
if left(yd(i),2)=left(sd,2) then
outd=cint(right(sd,2))-cint(right(yd(i),2))+1
else
outd=length(y,cint(left(yd(i),2)))+cint(right(sd,2))-cint(right(yd(i),2))+1
end if
outm=i
r=""
if yd(0)<>0 then
if outm=yd(0)+1 then r="闰"
if outm>cint(yd(0)) then outm=outm-1
end if
outy=y
gtoc="农历"&outy&"年"&r&outm&"月"&outd&"日"
End Function
End Class
|
