您所在位置：主题：万年历源程序
QB71
[专家分：1300] 发布于 2004-03-15 00:19:00
'这是一个万年历的程序 1920至2049年
'为了显示汉字和不用使用数据文件
'这个程序做了许多数据
'用了多个 DATA 语句，一些地方比较难以理解
'这并不是个好的编程风格
'可能是因为这个程序做得比较匆忙了
'如果那位比较有空，可以把程序改好一点
DECLARE SUB PP (Lx AS INTEGER, Ly AS INTEGER, nStr AS STRING)
DECLARE SUB sys.init ()
DECLARE FUNCTION list.wnl% (Year AS INTEGER, Month AS INTEGER)
DECLARE SUB Get.MyWnl (dy AS INTEGER, dm AS INTEGER, dd AS INTEGER)
DECLARE FUNCTION Get.Week% (dy AS INTEGER, dm AS INTEGER, dd AS INTEGER)
DECLARE FUNCTION Get.YearStr$ (Nober AS INTEGER)
DECLARE FUNCTION IsLeapYear% (dy AS INTEGER)
ON TIMER(1) GOSUB ListTime
TIMER ON
DEFINT A-Z
TYPE WnlType '万年历农历数据
LeapMM AS INTEGER '闰几月,一年有几月
BeginMd AS INTEGER '正月初一的国历,月,日
BeginGZ AS INTEGER '正月初一的天干地支
Months AS INTEGER '农历月的大小
END TYPE
TYPE MyWnlType '万年历农历的类型
Year AS STRING * 8 '年,如:二零零四
Month AS STRING * 4 '月,如:闰五
Day AS STRING * 4 '日,如:初一
END TYPE
'------------------------------------------
sys.init
DIM SHARED back(32) AS LONG '反白显示
REDIM SHARED Sday(0) AS INTEGER '一个月的天数
DIM SHARED MyWnl AS MyWnlType '定义万年历农历数据变量
DIM SHARED wnl AS WnlType '定义万年历数据变量
DIM SHARED Months(1 TO 12) AS INTEGER '定义国历一年十二个的数组
Months(1) = 31: Months(3) = 31: Months(4) = 30 '并赋值
Months(5) = 31: Months(6) = 30: Months(7) = 31
Months(8) = 31: Months(9) = 30: Months(10) = 31
Months(11) = 30: Months(12) = 31
'------------------------------------------
CONST false = 0, true = NOT false '定义真的假的常数
CONST Lx = 10, Ly = 25 '显示挂历的位置
'------------------------------------------
dt$ = DATE$ '取当前年月日
NowYear = VAL(MID$(dt$, 7, 4))
NowMonth = VAL(MID$(dt$, 1, 2))
NowDay = VAL(MID$(dt$, 4, 2))
LINE (0, 0)-(15, 15), 14, BF
GET (0, 0)-(15, 15), back
LINE (0, 0)-(15, 15), 0, BF
Get.MyWnl NowYear, NowMonth, NowDay '显示当前日期
Begin = list.wnl(NowYear, NowMonth)
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
Now.Loca = Begin + NowDay
GOSUB GetallLoca
PUT (now.x, now.y), back
GOSUB List.Date.Time
WHILE quit = 0
in$ = INKEY$ '取按键
IF in$ = CHR$(27) THEN quit = 1 '按 Esc 退出
IF in$ = CHR$(0) + CHR$(80) THEN '向下箭头键
PUT (now.x, now.y), back
Now.Loca = Now.Loca + 7
NowDay = NowDay + 7
IF NowDay > MaxDay THEN
NowDay = 1: NowMonth = NowMonth + 1
IF NowMonth > 12 THEN
NowMonth = 1: NowYear = NowYear + 1
IF NowYear > 2049 THEN NowYear = 2049
END IF
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
Now.Loca = list.wnl(NowYear, NowMonth) + NowDay
END IF
Get.MyWnl NowYear, NowMonth, NowDay
GOSUB GetallLoca
GOSUB List.Date.Time
PUT (now.x, now.y), back
END IF
IF in$ = CHR$(0) + CHR$(72) THEN '向上箭头键
PUT (now.x, now.y), back
Now.Loca = Now.Loca - 7
NowDay = NowDay - 7
IF NowDay < 1 THEN
NowMonth = NowMonth - 1
IF NowMonth < 1 THEN
NowMonth = 12: NowYear = NowYear - 1
IF NowYear < 1920 THEN NowYear = 1920
END IF
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
NowDay = MaxDay
Now.Loca = list.wnl(NowYear, NowMonth) + NowDay
END IF
Get.MyWnl NowYear, NowMonth, NowDay
GOSUB GetallLoca
GOSUB List.Date.Time
PUT (now.x, now.y), back
END IF
IF in$ = CHR$(0) + CHR$(77) THEN '向右箭头键
PUT (now.x, now.y), back
Now.Loca = Now.Loca + 1
NowDay = NowDay + 1
IF NowDay > MaxDay THEN
NowDay = 1: NowMonth = NowMonth + 1
IF NowMonth > 12 THEN
NowMonth = 1: NowYear = NowYear + 1
IF NowYear > 2049 THEN NowYear = 2049
END IF
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
Now.Loca = list.wnl(NowYear, NowMonth) + NowDay
END IF
Get.MyWnl NowYear, NowMonth, NowDay
GOSUB GetallLoca
GOSUB List.Date.Time
PUT (now.x, now.y), back
END IF
IF in$ = CHR$(0) + CHR$(75) THEN '向左箭头键
PUT (now.x, now.y), back
Now.Loca = Now.Loca - 1
NowDay = NowDay - 1
IF NowDay < 1 THEN
NowMonth = NowMonth - 1
IF NowMonth < 1 THEN
NowMonth = 12: NowYear = NowYear - 1
IF NowYear < 1920 THEN NowYear = 1920
END IF
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
NowDay = MaxDay
Now.Loca = list.wnl(NowYear, NowMonth) + NowDay
END IF
Get.MyWnl NowYear, NowMonth, NowDay
GOSUB GetallLoca
GOSUB List.Date.Time
PUT (now.x, now.y), back
END IF
IF in$ = CHR$(0) + CHR$(81) AND NowYear < 2049 THEN '下翻页
PUT (now.x, now.y), back
NowYear = NowYear + 1
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
IF NowDay > MaxDay THEN NowDay = MaxDay
Now.Loca = list.wnl(NowYear, NowMonth) + NowDay
Get.MyWnl NowYear, NowMonth, NowDay
GOSUB GetallLoca
GOSUB List.Date.Time
PUT (now.x, now.y), back
END IF
IF in$ = CHR$(0) + CHR$(73) AND NowYear > 1920 THEN '上翻页
PUT (now.x, now.y), back
NowYear = NowYear - 1
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
IF NowDay > MaxDay THEN NowDay = MaxDay
Now.Loca = list.wnl(NowYear, NowMonth) + NowDay
Get.MyWnl NowYear, NowMonth, NowDay
GOSUB GetallLoca
GOSUB List.Date.Time
PUT (now.x, now.y), back
END IF
WEND
END
GetallLoca: '取位置
Cx = INT((Now.Loca - 1) / 7)
cy = Now.Loca MOD 7
IF cy = 0 THEN cy = 7
cy = (cy - 1) * 4
now.x = (Ly + cy) * 8
now.y = (Lx + Cx - 1) * 16
RETURN
List.Date.Time: '显示农历和国历
PP 226, 278, LTRIM$(RTRIM$(STR$(NowYear)))
IF NowMonth < 10 THEN MM$ = " " ELSE MM$ = ""
PP 284, 278, LTRIM$(RTRIM$(STR$(NowMonth))) + MM$
IF NowDay < 10 THEN MM$ = " " ELSE MM$ = ""
PP 324, 278, LTRIM$(RTRIM$(STR$(NowDay))) + MM$
PP 226, 258, MyWnl.Year
PP 314, 258, MyWnl.Month
PP 372, 258, MyWnl.Day
PP 140, 400, Week$
RETURN
ListTime: '显示时间
PP 360, 279, TIME$
RETURN
'********************************************************************************
'汉字数据
DATA 1048592,-266342369,-266342369,65537,65537,-25166209
DATA -25166209,37814849,37814849,1956476061,1956476061,65537
DATA 65537,1880977437,1880977437,-2147319806,-2147319806
DATA 1611423756,1611423756,405936178,405936178
DATA 113313473,113313473,-535830513,-535830513,1073758208,1073758208
DATA -2147319806,-2147319806,65537,65537,-2147450880
DATA 1048592,0,0,0,0,0,0,0,0,0,0,0,0,67109888,67109888,-16777473
DATA -16777473,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
DATA 1048592,0,0,0,0,268439552,268439552,-130025409,-130025409,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,67109888,67109888,-16777473,-16777473,0,0,0,0,0
DATA 1048592,0,0,134219776,134219776,-58721153,-58721153,0,0,0,0,0,0
DATA 268439552,268439552,-130025409,-130025409,0,0,0,0,0,0,0,0,67109888
DATA 67109888,-16777473,-16777473,0,0,0
DATA 1048592,0,0,67109888,67109888,-25166209,-25166209,1145324612,1145324612
DATA 1145324612,1145324612,1145324612,1145324612,1145324612,1145324612,1145324612
DATA 1145324612,1145324612,1145324612,1011104836,1011104836,71828552,71828552
DATA 72352848,72352848,71304256,71304256,-58721153,-58721153,71304256,71304256,0
DATA 1048592,0,0,134219776,134219776,-58721153,-58721153,131074,131074,131074,131074
DATA 131074,131074,268570626,268570626,-62915521,-62915521,268701700,268701700,268701700
DATA 268701700,268701700,268701700,268963848,268963848,268963848,268963848
DATA 336073736,336073736,-16777473,-16777473,0,1048592,0,0,262148,262148,131074,131074
DATA 196611,196611,67175425,67175425,-16777473,-16777473,0,0,0,0,1074020356,1074020356
DATA 537665548,537665548,268963848,268963848,403707920,403707920,202378256,202378256
DATA 203426848,203426848,71304256,71304256,0,1048592,131074,131074,131074,131074,131074
DATA 131074,131074,131074,131074,131074,67240962,67240962,-33292797,-33292797,16646398
DATA 16646398,131074,131074,131074,131074,131074,131074,67240962,67240962,67240962,67240962
DATA 67240962,67240962,-66978815,-66978815,0,1048592,0,0,1073758208,1073758208,1074020356
DATA 1074020356,1074020356,1074020356,1074020356,1074020356,1074020356,1074020356,1074020356
DATA 1074020356,1074020356,1074020356,537403400,537403400,537403400,537403400,537403400,537403400
DATA 269488144,269488144,135268368,135268368,236981792,236981792,71304256,71304256,0
DATA 1048592,262148,262148,262148,262148,262148,262148,537141252,537141252,-251662081
DATA -251662081,537141252,537141252,537141252,537141252,537141252,537141252,537141252
DATA 537141252,537141252,537141252,537403400,537403400,537403400,537403400,571482640,571482640
DATA 571482640,571482640,505421344,505421344,12583104,1048592,65537,65537,65537,65537,65537
DATA 65537,65537,65537,65537,65537,67175425,67175425,-16777473,-16777473,65537,65537,65537
DATA 65537,65537,65537,65537,65537,65537,65537,65537,65537,65537,65537,65537,65537,65537
DATA 1048592,268439552,268439552,-132122593,-132122593,269488144,269488144,269488144,269488144
DATA 269488144,269488144,269488144,269488144,269488144,269488144,-266342369,-266342369
DATA 269488144,269488144,269488144,269488144,269488144,269488144,269488144,269488144,269488144
DATA 269488144,-266342369,-266342369,269488144,269488144,0,1048592,2097184,2097184,1048592,1048592
DATA 68158480,68158480,-33161723,-33161723,1157383420,1157383420,1141392392,1141392392,1141916688
DATA 1141916688,1144276020,1144276020,1146635352,1146635352,1150567572,1150567572,1141916688
DATA 1141916688,-2079292400,-2079292400,-2079292400,-2079292400,68224017,68224017,672278546,672278546,269750292
DATA 1048592,0,0,537403400,537403400,537403400,537403400,537403400,537403400,604513288,604513288,-16777473
DATA -16777473,537403400,537403400,537403400,537403400,537403400,537403400,537403400,537403400,537403400,537403400
DATA 537403400,537403400,537403400,537403400,537403400,537403400,-535830513,-535830513,537403400
DATA 1048592,69207072,69207072,-31719909,-31719909,67634184,67634184,608183360,608183360,-195038113
DATA -195038113,71369793,71369793,71369793,71369793,1145128001,1145128001,-464526257,-464526257
DATA 71369793,71369793,71369793,71369793,608248897,608248897,-195038113,-195038113,71304256,71304256
DATA 339743808,339743808,138414144,1048592,134219776,134219776,-58721153,-58721153,65537,65537,65537
DATA 65537,65537,65537,65537,65537,269553681,269553681,-133040111,-133040111,1114129,1114129,1114129,1114129
DATA 1114129,1114129,1114129,1114129,1114129,1114129,68224017,68224017,-16777473,-16777473,0
DATA 1048592,67109888,67109888,-25166209,-25166209,608183360,608183360,-195038113,-195038113,71369793,71369793
DATA 71369793,71369793,1145128001,1145128001,-464526257,-464526257,71369793,71369793,1145128001
DATA 1145128001,608248897,608248897,71369793,71369793,-195038113,-195038113,71304256,71304256
DATA -58721153,-58721153,71304256,1048592,134219776,134219776,-62915521,-62915521,2162721,2162721,2162721
DATA 2162721,2162721,2162721,69272609,69272609,-29360577,-29360577,69272609,69272609,69272609
DATA 69272609,69272609,69272609,69272609,69272609,69338146,69338146,71435330
DATA 71435330,1145324612,1145324612,680011912,680011912,269488144,1048592
DATA 524296,524296,134744072,134744072,-65012705,-65012705,1114129,1114129
DATA 2162721,2162721,272699457,272699457,-132122593,-132122593,1114129,1114129
DATA 1114129,1114129,68224017,68224017,-16777473,-16777473,65537,65537,65537
DATA 65537,65537,65537,65537,65537,65537,1048592,268439552,268439552,-133171185
DATA -133171185,268963848,268963848,268963848,268963848,268963848,268963848
DATA -267390961,-267390961,268963848,268963848,268963848,268963848,268963848
DATA 268963848,-267390961,-267390961,268963848,268963848,268963848,268963848
DATA 269488144,269488144,269488144,269488144,1344294944,1344294944,541073472
DATA 1048592,65537,65537,65537,65537,-25166209,-25166209,37814849,37814849,75564161
DATA 75564161,131074,131074,134350850,134350850,402987013,402987013,537468937,537468937
DATA -1072119784,-1072119784,-2144829400,-2144829400,1078476872,1078476872
DATA 814231688,814231688,235539978,235539978,67896332,67896332,524296
DATA 1048592,-2147450880,-2147450880,-2147188732,-2147188732,-2130804482
DATA -2130804482,-2080078844,-2080078844,-33227260,-33227260,134547461,134547461
DATA -2004973442,-2004973442,-2008774588,-2008774588,-2009036736,-2009036736
DATA 1346392128,1346392128,1346392128,1346392128,541073472,541073472,1347178572
DATA 1347178572,-2005890960,-2005890960,239144513,239144513,67503110
DATA 1048592,131074,131074,134285313,134285313,-58721153,-58721153,1074020356
DATA 1074020356,1343508500,1343508500,1209288724,1209288724,1277447204,1277447204
DATA 1145324612,1145324612,-266342369,-266342369,537403400,537403400,1074020356
DATA 1074020356,-2147319806,-2147319806,65537,65537,-1073561598,-1073561598
DATA 1007434764,1007434764,137365552,1048592,1074282504,1074282504,1075593244
DATA 1075593244,1089487088,1089487088,1074806800,1074806800,1141982225,1141982225
DATA 1291668733,1291668733,1343311889,1343311889,1077035058,1077035058,1077428280
DATA 1077428280,-1605066668,-1605066668,-1605328816,-1605328816,277942417,277942417
DATA 135333905,135333905,236064274,236064274,68420628,68420628,1572888
DATA 1048592,268439552,268439552,-130025409,-130025409,270536736,270536736
DATA 1344819240,1344819240,1344557092,1344557092,-1876783070,-1876783070
DATA -1876783070,-1876783070,270602273,270602273,270602273,270602273,-1876783070
DATA -1876783070,-1876783070,-1876783070,1344557092,1344557092,1344819240
DATA 1344819240,305140272,305140272,171969088,171969088,109053568
DATA 1048592,0,0,67109888,67109888,-16777473,-16777473,131074,131074,131074
DATA 131074,268570626,268570626,-133957629,-133957629,268570626,268570626
DATA 268570626,268570626,268701700,268701700,268701700,268701700,268701700
DATA 268701700,268963848,268963848,269488144,269488144,-1608474592,-1608474592
DATA 1077952576,1048592,0,0,0,0,0,0,0,0,1073758208,1073758208,805318656,805318656
DATA 1006648320,1006648320,-29360577,-29360577,1006648320,1006648320,805318656
DATA 805318656,1073758208,1073758208,0,0,0,0,0,0,0,0,0,1048592,0,0,0,0,0,0,0
DATA 0,65537,65537,393222,393222,1966110,1966110,-29360577,-29360577,1966110
DATA 1966110,393222,393222,65537,65537,0,0,0,0,0,0,0,0,0
DATA 1048592,0,0,-2147450880,-2147450880,-1073627135,-1073627135,-1073627135
DATA -1073627135,-536616957,-536616957,-536616957,-536616957,-1878749180
DATA -1878749180,-2147450880,-2147450880,-2147450880,-2147450880,-2147450880
DATA -2147450880,-2147450880,-2147450880,-2147450880,-2147450880,-2147450880
DATA -2147450880,-2147450880,-2147450880,-2147450880,-2147450880,0
DATA 1048592,0,0,-2147450880,-2147450880,-2147450880,-2147450880,-2147450880
DATA -2147450880,-2147450880,-2147450880,-2147450880,-2147450880,-2147450880
DATA -2147450880,-2147450880,-2147450880,-2147450880,-2147450880,-1878749180
DATA -1878749180,-536616957,-536616957,-536616957,-536616957,-1073627135
DATA -1073627135,-1073627135,-1073627135,-2147450880,-2147450880,0
'********************************************************************************
'英文和数字数据
DATA 1048584,0,0,-50529028,1717986918,1717986918,1717986918,2088533116,1616928864,1616928864,1616928864,1616928864,-252645136,0,0,0
DATA 1048584,0,0,0,0,0,1987475062,-858993460,-858993460,-858993460,-858993460,-858993460,2088533116,202116108,-858993460,2021161080
DATA 1048584,0,0,-117901064,1819044972,1717986918,1717986918,1717986918,1717986918,1717986918,1717986918,1819044972,-117901064,0,0,0
DATA 1048584,0,0,0,0,0,-589505316,1717986918,1717986918,1717986918,1717986918,1717986918,1717986918,0,0,0
DATA 1048584,0,0,-960051514,-960051514,-960051514,-960051514,-960051514,-960051514,-960051514,-960051514,-960051514,2088533116,0,0,0
DATA 1048584,0,0,0,0,0,-589505316,1717986918,1717986918,1717986918,1717986918,1717986918,2088533116,1616928864,1616928864,-252645136
DATA 1048584,0,0,943208504,1819044972,-960051514,-960051514,-690563370,-690563370,-960051514,-960051514,1819044972,943208504,0,0,0
DATA 1048584,0,0,404232216,943208504,2021161080,404232216,404232216,404232216,404232216,404232216,404232216,2122219134,0,0,0
DATA 1048584,0,0,2088533116,-960051514,101058054,202116108,404232216,808464432,1616928864,-1061109568,-960051514,-16843010,0,0,0
DATA 1048584,0,0,2088533116,-960051514,101058054,101058054,1010580540,101058054,101058054,101058054,-960051514,2088533116,0,0,0
DATA 1048584,0,0,202116108,471604252,1010580540,1819044972,-858993460,-16843010,202116108,202116108,202116108,505290270,0,0,0
DATA 1048584,0,0,-16843010,-1061109568,-1061109568,-1061109568,-50529028,101058054,101058054,101058054,-960051514,2088533116,0,0,0
DATA 1048584,0,0,943208504,1616928864,-1061109568,-1061109568,-50529028,-960051514,-960051514,-960051514,-960051514,2088533116,0,0,0
DATA 1048584,0,0,-16843010,-960051514,101058054,101058054,202116108,404232216,808464432,808464432,808464432,808464432,0,0,0
DATA 1048584,0,0,2088533116,-960051514,-960051514,-960051514,2088533116,-960051514,-960051514,-960051514,-960051514,2088533116,0,0,0
DATA 1048584,0,0,2088533116,-960051514,-960051514,-960051514,2122219134,101058054,101058054,101058054,202116108,2021161080,0,0,0
DATA 1048584,0,0,0,0,404232216,404232216,0,0,0,404232216,404232216,0,0,0,0
DATA 1048584,0,0,1010580540,1717986918,-1027423550,-1061109568,-1061109568,-1061109568,-1061109568,-1027423550,1717986918,1010580540,0,0,0
DATA 1048584,0,0,0,0,0,2088533116,-960051514,-960051514,-960051514,-960051514,-960051514,2088533116,0,0,0
DATA 1048584,0,0,0,0,0,-960051514,-960051514,-960051514,-960051514,-960051514,-960051514,2122219134,101058054,202116108,-117901064
DATA 1048584,0,0,0,0,0,-589505316,1987475062,1717986918,1616928864,1616928864,1616928864,-252645136,0,0,0
DATA 1048584,0,0,404232216,404232216,0,943208504,404232216,404232216,404232216,404232216,404232216,1010580540,0,0,0
DATA 1048584,0,0,-522133280,1616928864,1616928864,1819044972,1987475062,1717986918,1717986918,1717986918,1717986918,-421075226,0,0,0
DATA 1048584,0,0,269488144,808464432,808464432,-50529028,808464432,808464432,808464432,808464432,909522486,471604252,0,0,0
DATA 1048584,0,0,-16843010,1717986918,1650614882,1751672936,2021161080,1751672936,1616928864,1650614882,1717986918,-16843010,0,0,0
DATA 1048584,0,0,0,0,0,0,0,-16843010,0,0,0,0,0,0,0
DATA 1048584,0,0,0,0,0,-320017172,-16843010,-690563370,-690563370,-690563370,-690563370,-960051514,0,0,0
DATA 1048584,0,0,0,0,0,2021161080,202116108,2088533116,-858993460,-858993460,-858993460,1987475062,0,0,0
DATA 1048584,0,0,943208504,404232216,404232216,404232216,404232216,404232216,404232216,404232216,404232216,1010580540,0,0,0
DATA 1048584,0,0,0,0,0,-858993460,-858993460,-858993460,-858993460,-858993460,-858993460,1987475062,0,0,0
DATA 1048584,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,0
DATA 1048584,0,0,0,0,0,-960051514,-960051514,-690563370,-690563370,-690563370,-16843010,1819044972,0,0,0
DATA 1048584,0,0,0,2088533116,-960051514,-960051514,-555819298,-555819298,-555819298,-589505316,-1061109568,2088533116,0,0,0
DATA 1048584,0,0,0,0,0,0,0,0,0,0,404232216,404232216,0,0,0
DATA 1048584,0,0,0,0,0,2088533116,-960051514,-1061109568,-1061109568,-1061109568,-960051514,2088533116,0,0,0
DATA 1048584,0,0,2088533116,-960051514,-960051514,-960051514,-960051514,-960051514,-960051514,-690563370,-555819298,2088533116,202116108,235802126,0
DATA 1048584,0,0,202116108,404232216,808464432,808464432,808464432,808464432,808464432,808464432,404232216,202116108,0,0,0
DATA 1048584,0,0,808464432,404232216,202116108,202116108,202116108,202116108,202116108,202116108,404232216,808464432,0,0,0
'********************************************************************************
'万年历数据
DATA 3072,532,1289,3730,3072,520,2307,3365,3333,284,777,6733
DATA 3072,528,1801,2646,3072,517,259,694,3332,280,1289,5557
DATA 3072,525,2570,1748,3072,514,1028,3753,3330,279,2315,7826
DATA 3072,522,779,3730,3334,286,1797,3366,3072,529,2564,1323
DATA 3072,518,1034,2647,3333,282,2309,4790,3072,526,773,2906
DATA 3072,516,2060,1748,3331,280,518,3785,3072,523,1542,1865
DATA 3335,287,2572,5779,3072,531,1036,2707,3072,520,2054,1323
DATA 3334,283,524,2651,3072,527,1548,2733,3072,517,263,1386
DATA 3332,281,1281,6997,3072,525,2562,2980,3072,514,1032,2889
DATA 3330,278,2050,6803,3072,522,514,2709,3335,285,1544,5421
DATA 3072,529,2568,1334,3072,518,1026,2733,3333,283,2313,5546
DATA 3072,526,777,1458,3072,515,1795,3493,3331,280,522,7498
DATA 3072,524,1546,3402,3336,287,2564,2709,3072,530,771,2711
DATA 3072,520,2058,1366,3334,284,516,2741,3072,527,1540,2773
DATA 3072,517,267,1746,3332,281,1285,3749,3072,525,2309,3749
DATA 3072,514,1036,1610,3331,277,1797,3223,3072,521,261,2715
DATA 3335,286,1548,5466,3072,529,3084,1386,3072,518,1030,2921
DATA 3333,283,2305,5970,3072,527,769,2898,3072,515,1799,2853
DATA 3332,279,257,5707,3072,523,1281,2635,3336,287,2311,5291
DATA 3072,530,775,685,3072,519,1793,1389,3334,284,520,2921
DATA 3072,518,1544,3497,3072,517,259,3474,3332,281,1289,7461
DATA 3072,525,2313,3365,3338,514,771,6733,3072,532,1795,2646
DATA 3072,521,265,694,3334,285,1283,1461,3072,529,2307,1749
DATA 3072,518,1034,3753,3333,283,2309,7826,3072,527,773,3730
DATA 3072,516,1803,3366,3331,279,261,2646,3072,522,1028,2647
DATA 3336,287,2315,5334,3072,531,779,858,3072,519,1797,1749
DATA 3333,284,524,5833,3072,528,1548,1865,3072,517,2566,1683
DATA 3332,280,1036,5419,3072,524,2060,1323,3072,513,518,2651
DATA 3330,278,1793,5466,3072,521,257,1386,3335,285,1287,6997
DATA 3072,530,2568,2980,3072,519,1026,2889,3333,282,2056,6803
DATA 3072,526,520,2709,3072,515,1538,1325,3332,279,2568,2733
DATA 3072,522,1032,2733,3337,287,2307,5546,3072,531,771,1490
DATA 3072,520,1801,3493,3334,284,516,7498,3072,528,1540,3402
DATA 3072,517,2570,3221,3332,281,1028,5422,3072,524,2052,1366
DATA 3072,513,522,2741,3330,278,1797,5554,3072,522,261,1746
DATA 3334,285,1291,3753,3072,529,2315,1829,3072,518,773,1611
DATA 3333,282,1803,3223,3072,525,267,3243,3072,515,1542,1370
DATA 3331,279,2572,2774,3072,523,1036,2921,3335,287,2311,5970
DATA 3072,531,775,2898,3072,520,1793,2853,3334,284,263,6731
DATA 3072,527,1287,2635,3072,516,2305,1195,3333,280,775,1371
DATA 3072,524,1799,1453,3072,513,514,2922,3330,278,1801,6994
DATA 3072,522,265,3474,3335,286,1283,7461,3072,529,2307,3365
DATA 3072,518,777,2645,3333,282,1795,5293,3072,526,259,1206
DATA 3072,514,1289,1461,3331,279,2564,3498,209,19,0,0
SUB Get.MyWnl (dy AS INTEGER, dm AS INTEGER, dd AS INTEGER)
'***************************************************************
' 这个过程获得万年历的农历数据
'***************************************************************
CONST DayStr$ = "初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十"
CONST BigStr$ = "一二三四五六七八九十"
CONST MonthStr$ = "正二三四五六七八九十"
STATIC Lc AS INTEGER
STATIC Wdata() AS WnlType
STATIC WnlFile AS INTEGER
IF Lc = 0 THEN '第一次调用时打开数据文件
Lc = 1
REDIM Wdata(1 TO 130) AS WnlType
FOR I = 1 TO 130
READ Wdata(I).LeapMM
READ Wdata(I).BeginMd
READ Wdata(I).BeginGZ
READ Wdata(I).Months
NEXT
END IF
'------------------------------------------------------------
wnl = Wdata(dy - 1919) '取数据文件位置
Month = INT(wnl.BeginMd / 256)
Day = wnl.BeginMd MOD 256
IF dm < Month OR (dm = Month AND dd < Day) THEN '农历是上一年则
wnl = Wdata(dy - 1918) '重新取数据
Month = INT(wnl.BeginMd / 256)
Day = wnl.BeginMd MOD 256
befor.now = 1: Nober = dy - 1
GOSUB Get.Year.String
ELSE
befor.now = 0: Nober = dy
GOSUB Get.Year.String
END IF
AnyMonth = INT(wnl.LeapMM / 256) '取农历有几个月
Leap = wnl.LeapMM MOD 256 '取闰几月,如果为0则没闰
Ms = wnl.Months '取农历的大小月
'------------------------------------------------------------
'以下计算自农历正月初到现在过了多少天
IF befor.now = 1 THEN '农历是上一年
Days = 365 - IsLeapYear(dy - 1)
FOR I = 1 TO Month - 1
Days = Days - Months(I)
NEXT
Months(2) = 28 - IsLeapYear(dy)
FOR I = 1 TO dm - 1
Days = Days + Months(I)
NEXT
Days = Days + dd - Day
ELSE
Months(2) = 28 - IsLeapYear(dy)
FOR I = Month TO dm - 1
Days = Days + Months(I)
NEXT
Days = Days + dd - Day + 1
END IF
'------------------------------------------------------------
NN = 1
WHILE Days > 0 '求得农历的月和日
NowMonth = NowMonth + 1
IF NN AND Ms THEN tmpDay = 30 ELSE tmpDay = 29
Days = Days - tmpDay
NN = NN * 2
WEND
IF Days <= 0 THEN Days = Days + tmpDay
MyWnl.Day = MID$(DayStr$, (Days - 1) * 4 + 1, 4)
'------------------------------------------------------------
'以下获得月的大写形式
IF Leap > 0 THEN '是闰年
IF NowMonth <= Leap THEN tmp$ = MID$(MonthStr$, (NowMonth - 1) * 2 + 1, 2)
IF NowMonth = Leap + 1 THEN
tmp$ = "闰" + MID$(MonthStr$, (NowMonth - 2) * 2 + 1, 2)
END IF
IF NowMonth > Leap + 1 AND NowMonth < 12 THEN
tmp$ = MID$(MonthStr$, (NowMonth - 2) * 2 + 1, 2)
END IF
IF NowMonth = 12 THEN tmp$ = "十一"
IF NowMonth = 13 THEN tmp$ = "十二"
END IF
IF Leap = 0 THEN '不是闰年
IF NowMonth = 11 THEN tmp$ = "十一"
IF NowMonth = 12 THEN tmp$ = "十二"
IF NowMonth < 11 THEN tmp$ = MID$(MonthStr$, (NowMonth - 1) * 2 + 1, 2)
END IF
MyWnl.Month = tmp$
'------------------------------------------------------------
EXIT SUB
Get.Year.String:
CONST yStr$ = "零一二三四五六七八九"
FOR I = 1 TO 4
tmp$ = MID$(yStr$, (Nober MOD 10) * 2 + 1, 2) + tmp$
Nober = INT(Nober / 10)
NEXT
MyWnl.Year = tmp$
RETURN
END SUB
FUNCTION Get.Week (dy AS INTEGER, dm AS INTEGER, dd AS INTEGER)
'***********************************************************
' 这个函数返回国历 年,月,日 是星期几
'***********************************************************
DIM Days AS LONG
FOR I = 1900 TO dy - 1 '计算年1900年到现在有几天
Days = Days + 365 - IsLeapYear(I)
NEXT
Months(2) = 28 - IsLeapYear(dy) '平年2月28天,闰年29天
FOR I = 1 TO dm - 1
Days = Days + Months(I)
NEXT
Get.Week = (Days + dd) MOD 7 '取今天的星期
END FUNCTION
FUNCTION IsLeapYear (dy AS INTEGER)
'**************************************
' 这个函数得到 Dy 是否是闰年
'**************************************
IsLeapYear = (dy MOD 4 = 0 AND dy MOD 100 <> 0) OR dy MOD 400 = 0
END FUNCTION
FUNCTION list.wnl (Year AS INTEGER, Month AS INTEGER)
'********************************************
' 这个函数显示一月的挂历,并返回当月1号是星期几
'********************************************
LINE (190, 140)-(420, 250), 0, BF
NN = Get.Week(Year, Month, 1)
Months(2) = 28 - IsLeapYear(Year)
Mday = Months(Month) + NN
REDIM Sday(1 TO Mday) AS INTEGER
FOR I = 1 TO Mday
IF I < NN + 1 THEN
Sday(I) = 0
ELSE
Sday(I) = I - NN
END IF
NEXT
y = Ly: x = Lx
Months(2) = 28 - IsLeapYear(Year)
FOR I = 1 TO 38
IF I - NN <= Months(Month) THEN
IF Sday(I) > 0 THEN PP y * 8, (x - 1) * 16, LTRIM$(RTRIM$(STR$(Sday(I))))
END IF
y = y + 4
IF y > Ly + 27 THEN y = Ly: x = x + 1
NEXT
list.wnl = NN
END FUNCTION
SUB PP (Lx AS INTEGER, Ly AS INTEGER, nStr AS STRING)
'*****************************************
' 显示字符
'*****************************************
STATIC Lc%
STATIC lDig() AS LONG
STATIC lHz() AS LONG
IF Lc = 0 THEN
Lc = 1
REDIM lDig(16, 38) AS LONG
REDIM lHz(32, 30) AS LONG
FOR I = 0 TO 29
FOR J = 0 TO 31
READ lHz(J, I)
NEXT
NEXT
FOR I = 0 TO 37
FOR J = 0 TO 15
READ lDig(J, I)
NEXT
NEXT
END IF
CONST digs = "PgDnUp0123456789:CoyrihtE-malu_w@.cQ()"
CONST Hzs = "零一二三四五六七八九十日初廿闰正国历年月农改变秋风万→←↑↓"
Cx = Lx
TT$ = nStr
WHILE TT$ <> ""
IF ASC(LEFT$(TT$, 1)) < 161 THEN
A$ = LEFT$(TT$, 1)
TT$ = MID$(TT$, 2, LEN(TT$))
Here = INSTR(digs, A$)
IF Here > 0 THEN
PUT (Cx, Ly), lDig(0, Here - 1), PSET
ELSE
LINE (Cx, Ly)-(Cx + 7, Ly + 15), 0, BF
END IF
Cx = Cx + 8
ELSE
A$ = LEFT$(TT$, 2)
TT$ = MID$(TT$, 3, LEN(TT$))
Here = INSTR(Hzs, A$)
IF Here > 0 THEN
PUT (Cx, Ly), lHz(0, (Here - 1) / 2), PSET
END IF
Cx = Cx + 16
END IF
WEND
END SUB
SUB sys.init '****** 初始化程序并获得数据 **********
SCREEN 12
PP 230, 50, "万年历 1920-2049 年"
PP 174, 70, "秋风 Copyright(C) 2004年 3月 14日"
PP 154, 90, "E-mail:untill_wwy@163.com QQ:160190416"
PP 200, 120, "日 一 二 三 四 五 六"
PP 184, 258, "农历: 年 月 日"
PP 184, 278, "国历: 年 月 日"
PP 176, 310, "PgDn PgUp 改变年 →←↑↓ 改变日"
END SUB
'为了显示汉字和不用使用数据文件
'这个程序做了许多数据
'用了多个 DATA 语句，一些地方比较难以理解
'这并不是个好的编程风格
'可能是因为这个程序做得比较匆忙了
'如果那位比较有空，可以把程序改好一点
DECLARE SUB PP (Lx AS INTEGER, Ly AS INTEGER, nStr AS STRING)
DECLARE SUB sys.init ()
DECLARE FUNCTION list.wnl% (Year AS INTEGER, Month AS INTEGER)
DECLARE SUB Get.MyWnl (dy AS INTEGER, dm AS INTEGER, dd AS INTEGER)
DECLARE FUNCTION Get.Week% (dy AS INTEGER, dm AS INTEGER, dd AS INTEGER)
DECLARE FUNCTION Get.YearStr$ (Nober AS INTEGER)
DECLARE FUNCTION IsLeapYear% (dy AS INTEGER)
ON TIMER(1) GOSUB ListTime
TIMER ON
DEFINT A-Z
TYPE WnlType '万年历农历数据
LeapMM AS INTEGER '闰几月,一年有几月
BeginMd AS INTEGER '正月初一的国历,月,日
BeginGZ AS INTEGER '正月初一的天干地支
Months AS INTEGER '农历月的大小
END TYPE
TYPE MyWnlType '万年历农历的类型
Year AS STRING * 8 '年,如:二零零四
Month AS STRING * 4 '月,如:闰五
Day AS STRING * 4 '日,如:初一
END TYPE
'------------------------------------------
sys.init
DIM SHARED back(32) AS LONG '反白显示
REDIM SHARED Sday(0) AS INTEGER '一个月的天数
DIM SHARED MyWnl AS MyWnlType '定义万年历农历数据变量
DIM SHARED wnl AS WnlType '定义万年历数据变量
DIM SHARED Months(1 TO 12) AS INTEGER '定义国历一年十二个的数组
Months(1) = 31: Months(3) = 31: Months(4) = 30 '并赋值
Months(5) = 31: Months(6) = 30: Months(7) = 31
Months(8) = 31: Months(9) = 30: Months(10) = 31
Months(11) = 30: Months(12) = 31
'------------------------------------------
CONST false = 0, true = NOT false '定义真的假的常数
CONST Lx = 10, Ly = 25 '显示挂历的位置
'------------------------------------------
dt$ = DATE$ '取当前年月日
NowYear = VAL(MID$(dt$, 7, 4))
NowMonth = VAL(MID$(dt$, 1, 2))
NowDay = VAL(MID$(dt$, 4, 2))
LINE (0, 0)-(15, 15), 14, BF
GET (0, 0)-(15, 15), back
LINE (0, 0)-(15, 15), 0, BF
Get.MyWnl NowYear, NowMonth, NowDay '显示当前日期
Begin = list.wnl(NowYear, NowMonth)
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
Now.Loca = Begin + NowDay
GOSUB GetallLoca
PUT (now.x, now.y), back
GOSUB List.Date.Time
WHILE quit = 0
in$ = INKEY$ '取按键
IF in$ = CHR$(27) THEN quit = 1 '按 Esc 退出
IF in$ = CHR$(0) + CHR$(80) THEN '向下箭头键
PUT (now.x, now.y), back
Now.Loca = Now.Loca + 7
NowDay = NowDay + 7
IF NowDay > MaxDay THEN
NowDay = 1: NowMonth = NowMonth + 1
IF NowMonth > 12 THEN
NowMonth = 1: NowYear = NowYear + 1
IF NowYear > 2049 THEN NowYear = 2049
END IF
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
Now.Loca = list.wnl(NowYear, NowMonth) + NowDay
END IF
Get.MyWnl NowYear, NowMonth, NowDay
GOSUB GetallLoca
GOSUB List.Date.Time
PUT (now.x, now.y), back
END IF
IF in$ = CHR$(0) + CHR$(72) THEN '向上箭头键
PUT (now.x, now.y), back
Now.Loca = Now.Loca - 7
NowDay = NowDay - 7
IF NowDay < 1 THEN
NowMonth = NowMonth - 1
IF NowMonth < 1 THEN
NowMonth = 12: NowYear = NowYear - 1
IF NowYear < 1920 THEN NowYear = 1920
END IF
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
NowDay = MaxDay
Now.Loca = list.wnl(NowYear, NowMonth) + NowDay
END IF
Get.MyWnl NowYear, NowMonth, NowDay
GOSUB GetallLoca
GOSUB List.Date.Time
PUT (now.x, now.y), back
END IF
IF in$ = CHR$(0) + CHR$(77) THEN '向右箭头键
PUT (now.x, now.y), back
Now.Loca = Now.Loca + 1
NowDay = NowDay + 1
IF NowDay > MaxDay THEN
NowDay = 1: NowMonth = NowMonth + 1
IF NowMonth > 12 THEN
NowMonth = 1: NowYear = NowYear + 1
IF NowYear > 2049 THEN NowYear = 2049
END IF
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
Now.Loca = list.wnl(NowYear, NowMonth) + NowDay
END IF
Get.MyWnl NowYear, NowMonth, NowDay
GOSUB GetallLoca
GOSUB List.Date.Time
PUT (now.x, now.y), back
END IF
IF in$ = CHR$(0) + CHR$(75) THEN '向左箭头键
PUT (now.x, now.y), back
Now.Loca = Now.Loca - 1
NowDay = NowDay - 1
IF NowDay < 1 THEN
NowMonth = NowMonth - 1
IF NowMonth < 1 THEN
NowMonth = 12: NowYear = NowYear - 1
IF NowYear < 1920 THEN NowYear = 1920
END IF
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
NowDay = MaxDay
Now.Loca = list.wnl(NowYear, NowMonth) + NowDay
END IF
Get.MyWnl NowYear, NowMonth, NowDay
GOSUB GetallLoca
GOSUB List.Date.Time
PUT (now.x, now.y), back
END IF
IF in$ = CHR$(0) + CHR$(81) AND NowYear < 2049 THEN '下翻页
PUT (now.x, now.y), back
NowYear = NowYear + 1
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
IF NowDay > MaxDay THEN NowDay = MaxDay
Now.Loca = list.wnl(NowYear, NowMonth) + NowDay
Get.MyWnl NowYear, NowMonth, NowDay
GOSUB GetallLoca
GOSUB List.Date.Time
PUT (now.x, now.y), back
END IF
IF in$ = CHR$(0) + CHR$(73) AND NowYear > 1920 THEN '上翻页
PUT (now.x, now.y), back
NowYear = NowYear - 1
Months(2) = 28 - IsLeapYear(NowYear)
MaxDay = Months(NowMonth)
IF NowDay > MaxDay THEN NowDay = MaxDay
Now.Loca = list.wnl(NowYear, NowMonth) + NowDay
Get.MyWnl NowYear, NowMonth, NowDay
GOSUB GetallLoca
GOSUB List.Date.Time
PUT (now.x, now.y), back
END IF
WEND
END
GetallLoca: '取位置
Cx = INT((Now.Loca - 1) / 7)
cy = Now.Loca MOD 7
IF cy = 0 THEN cy = 7
cy = (cy - 1) * 4
now.x = (Ly + cy) * 8
now.y = (Lx + Cx - 1) * 16
RETURN
List.Date.Time: '显示农历和国历
PP 226, 278, LTRIM$(RTRIM$(STR$(NowYear)))
IF NowMonth < 10 THEN MM$ = " " ELSE MM$ = ""
PP 284, 278, LTRIM$(RTRIM$(STR$(NowMonth))) + MM$
IF NowDay < 10 THEN MM$ = " " ELSE MM$ = ""
PP 324, 278, LTRIM$(RTRIM$(STR$(NowDay))) + MM$
PP 226, 258, MyWnl.Year
PP 314, 258, MyWnl.Month
PP 372, 258, MyWnl.Day
PP 140, 400, Week$
RETURN
ListTime: '显示时间
PP 360, 279, TIME$
RETURN
'********************************************************************************
'汉字数据
DATA 1048592,-266342369,-266342369,65537,65537,-25166209
DATA -25166209,37814849,37814849,1956476061,1956476061,65537
DATA 65537,1880977437,1880977437,-2147319806,-2147319806
DATA 1611423756,1611423756,405936178,405936178
DATA 113313473,113313473,-535830513,-535830513,1073758208,1073758208
DATA -2147319806,-2147319806,65537,65537,-2147450880
DATA 1048592,0,0,0,0,0,0,0,0,0,0,0,0,67109888,67109888,-16777473
DATA -16777473,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
DATA 1048592,0,0,0,0,268439552,268439552,-130025409,-130025409,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,67109888,67109888,-16777473,-16777473,0,0,0,0,0
DATA 1048592,0,0,134219776,134219776,-58721153,-58721153,0,0,0,0,0,0
DATA 268439552,268439552,-130025409,-130025409,0,0,0,0,0,0,0,0,67109888
DATA 67109888,-16777473,-16777473,0,0,0
DATA 1048592,0,0,67109888,67109888,-25166209,-25166209,1145324612,1145324612
DATA 1145324612,1145324612,1145324612,1145324612,1145324612,1145324612,1145324612
DATA 1145324612,1145324612,1145324612,1011104836,1011104836,71828552,71828552
DATA 72352848,72352848,71304256,71304256,-58721153,-58721153,71304256,71304256,0
DATA 1048592,0,0,134219776,134219776,-58721153,-58721153,131074,131074,131074,131074
DATA 131074,131074,268570626,268570626,-62915521,-62915521,268701700,268701700,268701700
DATA 268701700,268701700,268701700,268963848,268963848,268963848,268963848
DATA 336073736,336073736,-16777473,-16777473,0,1048592,0,0,262148,262148,131074,131074
DATA 196611,196611,67175425,67175425,-16777473,-16777473,0,0,0,0,1074020356,1074020356
DATA 537665548,537665548,268963848,268963848,403707920,403707920,202378256,202378256
DATA 203426848,203426848,71304256,71304256,0,1048592,131074,131074,131074,131074,131074
DATA 131074,131074,131074,131074,131074,67240962,67240962,-33292797,-33292797,16646398
DATA 16646398,131074,131074,131074,131074,131074,131074,67240962,67240962,67240962,67240962
DATA 67240962,67240962,-66978815,-66978815,0,1048592,0,0,1073758208,1073758208,1074020356
DATA 1074020356,1074020356,1074020356,1074020356,1074020356,1074020356,1074020356,1074020356
DATA 1074020356,1074020356,1074020356,537403400,537403400,537403400,537403400,537403400,537403400
DATA 269488144,269488144,135268368,135268368,236981792,236981792,71304256,71304256,0
DATA 1048592,262148,262148,262148,262148,262148,262148,537141252,537141252,-251662081
DATA -251662081,537141252,537141252,537141252,537141252,537141252,537141252,537141252
DATA 537141252,537141252,537141252,537403400,537403400,537403400,537403400,571482640,571482640
DATA 571482640,571482640,505421344,505421344,12583104,1048592,65537,65537,65537,65537,65537
DATA 65537,65537,65537,65537,65537,67175425,67175425,-16777473,-16777473,65537,65537,65537
DATA 65537,65537,65537,65537,65537,65537,65537,65537,65537,65537,65537,65537,65537,65537
DATA 1048592,268439552,268439552,-132122593,-132122593,269488144,269488144,269488144,269488144
DATA 269488144,269488144,269488144,269488144,269488144,269488144,-266342369,-266342369
DATA 269488144,269488144,269488144,269488144,269488144,269488144,269488144,269488144,269488144
DATA 269488144,-266342369,-266342369,269488144,269488144,0,1048592,2097184,2097184,1048592,1048592
DATA 68158480,68158480,-33161723,-33161723,1157383420,1157383420,1141392392,1141392392,1141916688
DATA 1141916688,1144276020,1144276020,1146635352,1146635352,1150567572,1150567572,1141916688
DATA 1141916688,-2079292400,-2079292400,-2079292400,-2079292400,68224017,68224017,672278546,672278546,269750292
DATA 1048592,0,0,537403400,537403400,537403400,537403400,537403400,537403400,604513288,604513288,-16777473
DATA -16777473,537403400,537403400,537403400,537403400,537403400,537403400,537403400,537403400,537403400,537403400
DATA 537403400,537403400,537403400,537403400,537403400,537403400,-535830513,-535830513,537403400
DATA 1048592,69207072,69207072,-31719909,-31719909,67634184,67634184,608183360,608183360,-195038113
DATA -195038113,71369793,71369793,71369793,71369793,1145128001,1145128001,-464526257,-464526257
DATA 71369793,71369793,71369793,71369793,608248897,608248897,-195038113,-195038113,71304256,71304256
DATA 339743808,339743808,138414144,1048592,134219776,134219776,-58721153,-58721153,65537,65537,65537
DATA 65537,65537,65537,65537,65537,269553681,269553681,-133040111,-133040111,1114129,1114129,1114129,1114129
DATA 1114129,1114129,1114129,1114129,1114129,1114129,68224017,68224017,-16777473,-16777473,0
DATA 1048592,67109888,67109888,-25166209,-25166209,608183360,608183360,-195038113,-195038113,71369793,71369793
DATA 71369793,71369793,1145128001,1145128001,-464526257,-464526257,71369793,71369793,1145128001
DATA 1145128001,608248897,608248897,71369793,71369793,-195038113,-195038113,71304256,71304256
DATA -58721153,-58721153,71304256,1048592,134219776,134219776,-62915521,-62915521,2162721,2162721,2162721
DATA 2162721,2162721,2162721,69272609,69272609,-29360577,-29360577,69272609,69272609,69272609
DATA 69272609,69272609,69272609,69272609,69272609,69338146,69338146,71435330
DATA 71435330,1145324612,1145324612,680011912,680011912,269488144,1048592
DATA 524296,524296,134744072,134744072,-65012705,-65012705,1114129,1114129
DATA 2162721,2162721,272699457,272699457,-132122593,-132122593,1114129,1114129
DATA 1114129,1114129,68224017,68224017,-16777473,-16777473,65537,65537,65537
DATA 65537,65537,65537,65537,65537,65537,1048592,268439552,268439552,-133171185
DATA -133171185,268963848,268963848,268963848,268963848,268963848,268963848
DATA -267390961,-267390961,268963848,268963848,268963848,268963848,268963848
DATA 268963848,-267390961,-267390961,268963848,268963848,268963848,268963848
DATA 269488144,269488144,269488144,269488144,1344294944,1344294944,541073472
DATA 1048592,65537,65537,65537,65537,-25166209,-25166209,37814849,37814849,75564161
DATA 75564161,131074,131074,134350850,134350850,402987013,402987013,537468937,537468937
DATA -1072119784,-1072119784,-2144829400,-2144829400,1078476872,1078476872
DATA 814231688,814231688,235539978,235539978,67896332,67896332,524296
DATA 1048592,-2147450880,-2147450880,-2147188732,-2147188732,-2130804482
DATA -2130804482,-2080078844,-2080078844,-33227260,-33227260,134547461,134547461
DATA -2004973442,-2004973442,-2008774588,-2008774588,-2009036736,-2009036736
DATA 1346392128,1346392128,1346392128,1346392128,541073472,541073472,1347178572
DATA 1347178572,-2005890960,-2005890960,239144513,239144513,67503110
DATA 1048592,131074,131074,134285313,134285313,-58721153,-58721153,1074020356
DATA 1074020356,1343508500,1343508500,1209288724,1209288724,1277447204,1277447204
DATA 1145324612,1145324612,-266342369,-266342369,537403400,537403400,1074020356
DATA 1074020356,-2147319806,-2147319806,65537,65537,-1073561598,-1073561598
DATA 1007434764,1007434764,137365552,1048592,1074282504,1074282504,1075593244
DATA 1075593244,1089487088,1089487088,1074806800,1074806800,1141982225,1141982225
DATA 1291668733,1291668733,1343311889,1343311889,1077035058,1077035058,1077428280
DATA 1077428280,-1605066668,-1605066668,-1605328816,-1605328816,277942417,277942417
DATA 135333905,135333905,236064274,236064274,68420628,68420628,1572888
DATA 1048592,268439552,268439552,-130025409,-130025409,270536736,270536736
DATA 1344819240,1344819240,1344557092,1344557092,-1876783070,-1876783070
DATA -1876783070,-1876783070,270602273,270602273,270602273,270602273,-1876783070
DATA -1876783070,-1876783070,-1876783070,1344557092,1344557092,1344819240
DATA 1344819240,305140272,305140272,171969088,171969088,109053568
DATA 1048592,0,0,67109888,67109888,-16777473,-16777473,131074,131074,131074
DATA 131074,268570626,268570626,-133957629,-133957629,268570626,268570626
DATA 268570626,268570626,268701700,268701700,268701700,268701700,268701700
DATA 268701700,268963848,268963848,269488144,269488144,-1608474592,-1608474592
DATA 1077952576,1048592,0,0,0,0,0,0,0,0,1073758208,1073758208,805318656,805318656
DATA 1006648320,1006648320,-29360577,-29360577,1006648320,1006648320,805318656
DATA 805318656,1073758208,1073758208,0,0,0,0,0,0,0,0,0,1048592,0,0,0,0,0,0,0
DATA 0,65537,65537,393222,393222,1966110,1966110,-29360577,-29360577,1966110
DATA 1966110,393222,393222,65537,65537,0,0,0,0,0,0,0,0,0
DATA 1048592,0,0,-2147450880,-2147450880,-1073627135,-1073627135,-1073627135
DATA -1073627135,-536616957,-536616957,-536616957,-536616957,-1878749180
DATA -1878749180,-2147450880,-2147450880,-2147450880,-2147450880,-2147450880
DATA -2147450880,-2147450880,-2147450880,-2147450880,-2147450880,-2147450880
DATA -2147450880,-2147450880,-2147450880,-2147450880,-2147450880,0
DATA 1048592,0,0,-2147450880,-2147450880,-2147450880,-2147450880,-2147450880
DATA -2147450880,-2147450880,-2147450880,-2147450880,-2147450880,-2147450880
DATA -2147450880,-2147450880,-2147450880,-2147450880,-2147450880,-1878749180
DATA -1878749180,-536616957,-536616957,-536616957,-536616957,-1073627135
DATA -1073627135,-1073627135,-1073627135,-2147450880,-2147450880,0
'********************************************************************************
'英文和数字数据
DATA 1048584,0,0,-50529028,1717986918,1717986918,1717986918,2088533116,1616928864,1616928864,1616928864,1616928864,-252645136,0,0,0
DATA 1048584,0,0,0,0,0,1987475062,-858993460,-858993460,-858993460,-858993460,-858993460,2088533116,202116108,-858993460,2021161080
DATA 1048584,0,0,-117901064,1819044972,1717986918,1717986918,1717986918,1717986918,1717986918,1717986918,1819044972,-117901064,0,0,0
DATA 1048584,0,0,0,0,0,-589505316,1717986918,1717986918,1717986918,1717986918,1717986918,1717986918,0,0,0
DATA 1048584,0,0,-960051514,-960051514,-960051514,-960051514,-960051514,-960051514,-960051514,-960051514,-960051514,2088533116,0,0,0
DATA 1048584,0,0,0,0,0,-589505316,1717986918,1717986918,1717986918,1717986918,1717986918,2088533116,1616928864,1616928864,-252645136
DATA 1048584,0,0,943208504,1819044972,-960051514,-960051514,-690563370,-690563370,-960051514,-960051514,1819044972,943208504,0,0,0
DATA 1048584,0,0,404232216,943208504,2021161080,404232216,404232216,404232216,404232216,404232216,404232216,2122219134,0,0,0
DATA 1048584,0,0,2088533116,-960051514,101058054,202116108,404232216,808464432,1616928864,-1061109568,-960051514,-16843010,0,0,0
DATA 1048584,0,0,2088533116,-960051514,101058054,101058054,1010580540,101058054,101058054,101058054,-960051514,2088533116,0,0,0
DATA 1048584,0,0,202116108,471604252,1010580540,1819044972,-858993460,-16843010,202116108,202116108,202116108,505290270,0,0,0
DATA 1048584,0,0,-16843010,-1061109568,-1061109568,-1061109568,-50529028,101058054,101058054,101058054,-960051514,2088533116,0,0,0
DATA 1048584,0,0,943208504,1616928864,-1061109568,-1061109568,-50529028,-960051514,-960051514,-960051514,-960051514,2088533116,0,0,0
DATA 1048584,0,0,-16843010,-960051514,101058054,101058054,202116108,404232216,808464432,808464432,808464432,808464432,0,0,0
DATA 1048584,0,0,2088533116,-960051514,-960051514,-960051514,2088533116,-960051514,-960051514,-960051514,-960051514,2088533116,0,0,0
DATA 1048584,0,0,2088533116,-960051514,-960051514,-960051514,2122219134,101058054,101058054,101058054,202116108,2021161080,0,0,0
DATA 1048584,0,0,0,0,404232216,404232216,0,0,0,404232216,404232216,0,0,0,0
DATA 1048584,0,0,1010580540,1717986918,-1027423550,-1061109568,-1061109568,-1061109568,-1061109568,-1027423550,1717986918,1010580540,0,0,0
DATA 1048584,0,0,0,0,0,2088533116,-960051514,-960051514,-960051514,-960051514,-960051514,2088533116,0,0,0
DATA 1048584,0,0,0,0,0,-960051514,-960051514,-960051514,-960051514,-960051514,-960051514,2122219134,101058054,202116108,-117901064
DATA 1048584,0,0,0,0,0,-589505316,1987475062,1717986918,1616928864,1616928864,1616928864,-252645136,0,0,0
DATA 1048584,0,0,404232216,404232216,0,943208504,404232216,404232216,404232216,404232216,404232216,1010580540,0,0,0
DATA 1048584,0,0,-522133280,1616928864,1616928864,1819044972,1987475062,1717986918,1717986918,1717986918,1717986918,-421075226,0,0,0
DATA 1048584,0,0,269488144,808464432,808464432,-50529028,808464432,808464432,808464432,808464432,909522486,471604252,0,0,0
DATA 1048584,0,0,-16843010,1717986918,1650614882,1751672936,2021161080,1751672936,1616928864,1650614882,1717986918,-16843010,0,0,0
DATA 1048584,0,0,0,0,0,0,0,-16843010,0,0,0,0,0,0,0
DATA 1048584,0,0,0,0,0,-320017172,-16843010,-690563370,-690563370,-690563370,-690563370,-960051514,0,0,0
DATA 1048584,0,0,0,0,0,2021161080,202116108,2088533116,-858993460,-858993460,-858993460,1987475062,0,0,0
DATA 1048584,0,0,943208504,404232216,404232216,404232216,404232216,404232216,404232216,404232216,404232216,1010580540,0,0,0
DATA 1048584,0,0,0,0,0,-858993460,-858993460,-858993460,-858993460,-858993460,-858993460,1987475062,0,0,0
DATA 1048584,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,0
DATA 1048584,0,0,0,0,0,-960051514,-960051514,-690563370,-690563370,-690563370,-16843010,1819044972,0,0,0
DATA 1048584,0,0,0,2088533116,-960051514,-960051514,-555819298,-555819298,-555819298,-589505316,-1061109568,2088533116,0,0,0
DATA 1048584,0,0,0,0,0,0,0,0,0,0,404232216,404232216,0,0,0
DATA 1048584,0,0,0,0,0,2088533116,-960051514,-1061109568,-1061109568,-1061109568,-960051514,2088533116,0,0,0
DATA 1048584,0,0,2088533116,-960051514,-960051514,-960051514,-960051514,-960051514,-960051514,-690563370,-555819298,2088533116,202116108,235802126,0
DATA 1048584,0,0,202116108,404232216,808464432,808464432,808464432,808464432,808464432,808464432,404232216,202116108,0,0,0
DATA 1048584,0,0,808464432,404232216,202116108,202116108,202116108,202116108,202116108,202116108,404232216,808464432,0,0,0
'********************************************************************************
'万年历数据
DATA 3072,532,1289,3730,3072,520,2307,3365,3333,284,777,6733
DATA 3072,528,1801,2646,3072,517,259,694,3332,280,1289,5557
DATA 3072,525,2570,1748,3072,514,1028,3753,3330,279,2315,7826
DATA 3072,522,779,3730,3334,286,1797,3366,3072,529,2564,1323
DATA 3072,518,1034,2647,3333,282,2309,4790,3072,526,773,2906
DATA 3072,516,2060,1748,3331,280,518,3785,3072,523,1542,1865
DATA 3335,287,2572,5779,3072,531,1036,2707,3072,520,2054,1323
DATA 3334,283,524,2651,3072,527,1548,2733,3072,517,263,1386
DATA 3332,281,1281,6997,3072,525,2562,2980,3072,514,1032,2889
DATA 3330,278,2050,6803,3072,522,514,2709,3335,285,1544,5421
DATA 3072,529,2568,1334,3072,518,1026,2733,3333,283,2313,5546
DATA 3072,526,777,1458,3072,515,1795,3493,3331,280,522,7498
DATA 3072,524,1546,3402,3336,287,2564,2709,3072,530,771,2711
DATA 3072,520,2058,1366,3334,284,516,2741,3072,527,1540,2773
DATA 3072,517,267,1746,3332,281,1285,3749,3072,525,2309,3749
DATA 3072,514,1036,1610,3331,277,1797,3223,3072,521,261,2715
DATA 3335,286,1548,5466,3072,529,3084,1386,3072,518,1030,2921
DATA 3333,283,2305,5970,3072,527,769,2898,3072,515,1799,2853
DATA 3332,279,257,5707,3072,523,1281,2635,3336,287,2311,5291
DATA 3072,530,775,685,3072,519,1793,1389,3334,284,520,2921
DATA 3072,518,1544,3497,3072,517,259,3474,3332,281,1289,7461
DATA 3072,525,2313,3365,3338,514,771,6733,3072,532,1795,2646
DATA 3072,521,265,694,3334,285,1283,1461,3072,529,2307,1749
DATA 3072,518,1034,3753,3333,283,2309,7826,3072,527,773,3730
DATA 3072,516,1803,3366,3331,279,261,2646,3072,522,1028,2647
DATA 3336,287,2315,5334,3072,531,779,858,3072,519,1797,1749
DATA 3333,284,524,5833,3072,528,1548,1865,3072,517,2566,1683
DATA 3332,280,1036,5419,3072,524,2060,1323,3072,513,518,2651
DATA 3330,278,1793,5466,3072,521,257,1386,3335,285,1287,6997
DATA 3072,530,2568,2980,3072,519,1026,2889,3333,282,2056,6803
DATA 3072,526,520,2709,3072,515,1538,1325,3332,279,2568,2733
DATA 3072,522,1032,2733,3337,287,2307,5546,3072,531,771,1490
DATA 3072,520,1801,3493,3334,284,516,7498,3072,528,1540,3402
DATA 3072,517,2570,3221,3332,281,1028,5422,3072,524,2052,1366
DATA 3072,513,522,2741,3330,278,1797,5554,3072,522,261,1746
DATA 3334,285,1291,3753,3072,529,2315,1829,3072,518,773,1611
DATA 3333,282,1803,3223,3072,525,267,3243,3072,515,1542,1370
DATA 3331,279,2572,2774,3072,523,1036,2921,3335,287,2311,5970
DATA 3072,531,775,2898,3072,520,1793,2853,3334,284,263,6731
DATA 3072,527,1287,2635,3072,516,2305,1195,3333,280,775,1371
DATA 3072,524,1799,1453,3072,513,514,2922,3330,278,1801,6994
DATA 3072,522,265,3474,3335,286,1283,7461,3072,529,2307,3365
DATA 3072,518,777,2645,3333,282,1795,5293,3072,526,259,1206
DATA 3072,514,1289,1461,3331,279,2564,3498,209,19,0,0
SUB Get.MyWnl (dy AS INTEGER, dm AS INTEGER, dd AS INTEGER)
'***************************************************************
' 这个过程获得万年历的农历数据
'***************************************************************
CONST DayStr$ = "初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十"
CONST BigStr$ = "一二三四五六七八九十"
CONST MonthStr$ = "正二三四五六七八九十"
STATIC Lc AS INTEGER
STATIC Wdata() AS WnlType
STATIC WnlFile AS INTEGER
IF Lc = 0 THEN '第一次调用时打开数据文件
Lc = 1
REDIM Wdata(1 TO 130) AS WnlType
FOR I = 1 TO 130
READ Wdata(I).LeapMM
READ Wdata(I).BeginMd
READ Wdata(I).BeginGZ
READ Wdata(I).Months
NEXT
END IF
'------------------------------------------------------------
wnl = Wdata(dy - 1919) '取数据文件位置
Month = INT(wnl.BeginMd / 256)
Day = wnl.BeginMd MOD 256
IF dm < Month OR (dm = Month AND dd < Day) THEN '农历是上一年则
wnl = Wdata(dy - 1918) '重新取数据
Month = INT(wnl.BeginMd / 256)
Day = wnl.BeginMd MOD 256
befor.now = 1: Nober = dy - 1
GOSUB Get.Year.String
ELSE
befor.now = 0: Nober = dy
GOSUB Get.Year.String
END IF
AnyMonth = INT(wnl.LeapMM / 256) '取农历有几个月
Leap = wnl.LeapMM MOD 256 '取闰几月,如果为0则没闰
Ms = wnl.Months '取农历的大小月
'------------------------------------------------------------
'以下计算自农历正月初到现在过了多少天
IF befor.now = 1 THEN '农历是上一年
Days = 365 - IsLeapYear(dy - 1)
FOR I = 1 TO Month - 1
Days = Days - Months(I)
NEXT
Months(2) = 28 - IsLeapYear(dy)
FOR I = 1 TO dm - 1
Days = Days + Months(I)
NEXT
Days = Days + dd - Day
ELSE
Months(2) = 28 - IsLeapYear(dy)
FOR I = Month TO dm - 1
Days = Days + Months(I)
NEXT
Days = Days + dd - Day + 1
END IF
'------------------------------------------------------------
NN = 1
WHILE Days > 0 '求得农历的月和日
NowMonth = NowMonth + 1
IF NN AND Ms THEN tmpDay = 30 ELSE tmpDay = 29
Days = Days - tmpDay
NN = NN * 2
WEND
IF Days <= 0 THEN Days = Days + tmpDay
MyWnl.Day = MID$(DayStr$, (Days - 1) * 4 + 1, 4)
'------------------------------------------------------------
'以下获得月的大写形式
IF Leap > 0 THEN '是闰年
IF NowMonth <= Leap THEN tmp$ = MID$(MonthStr$, (NowMonth - 1) * 2 + 1, 2)
IF NowMonth = Leap + 1 THEN
tmp$ = "闰" + MID$(MonthStr$, (NowMonth - 2) * 2 + 1, 2)
END IF
IF NowMonth > Leap + 1 AND NowMonth < 12 THEN
tmp$ = MID$(MonthStr$, (NowMonth - 2) * 2 + 1, 2)
END IF
IF NowMonth = 12 THEN tmp$ = "十一"
IF NowMonth = 13 THEN tmp$ = "十二"
END IF
IF Leap = 0 THEN '不是闰年
IF NowMonth = 11 THEN tmp$ = "十一"
IF NowMonth = 12 THEN tmp$ = "十二"
IF NowMonth < 11 THEN tmp$ = MID$(MonthStr$, (NowMonth - 1) * 2 + 1, 2)
END IF
MyWnl.Month = tmp$
'------------------------------------------------------------
EXIT SUB
Get.Year.String:
CONST yStr$ = "零一二三四五六七八九"
FOR I = 1 TO 4
tmp$ = MID$(yStr$, (Nober MOD 10) * 2 + 1, 2) + tmp$
Nober = INT(Nober / 10)
NEXT
MyWnl.Year = tmp$
RETURN
END SUB
FUNCTION Get.Week (dy AS INTEGER, dm AS INTEGER, dd AS INTEGER)
'***********************************************************
' 这个函数返回国历 年,月,日 是星期几
'***********************************************************
DIM Days AS LONG
FOR I = 1900 TO dy - 1 '计算年1900年到现在有几天
Days = Days + 365 - IsLeapYear(I)
NEXT
Months(2) = 28 - IsLeapYear(dy) '平年2月28天,闰年29天
FOR I = 1 TO dm - 1
Days = Days + Months(I)
NEXT
Get.Week = (Days + dd) MOD 7 '取今天的星期
END FUNCTION
FUNCTION IsLeapYear (dy AS INTEGER)
'**************************************
' 这个函数得到 Dy 是否是闰年
'**************************************
IsLeapYear = (dy MOD 4 = 0 AND dy MOD 100 <> 0) OR dy MOD 400 = 0
END FUNCTION
FUNCTION list.wnl (Year AS INTEGER, Month AS INTEGER)
'********************************************
' 这个函数显示一月的挂历,并返回当月1号是星期几
'********************************************
LINE (190, 140)-(420, 250), 0, BF
NN = Get.Week(Year, Month, 1)
Months(2) = 28 - IsLeapYear(Year)
Mday = Months(Month) + NN
REDIM Sday(1 TO Mday) AS INTEGER
FOR I = 1 TO Mday
IF I < NN + 1 THEN
Sday(I) = 0
ELSE
Sday(I) = I - NN
END IF
NEXT
y = Ly: x = Lx
Months(2) = 28 - IsLeapYear(Year)
FOR I = 1 TO 38
IF I - NN <= Months(Month) THEN
IF Sday(I) > 0 THEN PP y * 8, (x - 1) * 16, LTRIM$(RTRIM$(STR$(Sday(I))))
END IF
y = y + 4
IF y > Ly + 27 THEN y = Ly: x = x + 1
NEXT
list.wnl = NN
END FUNCTION
SUB PP (Lx AS INTEGER, Ly AS INTEGER, nStr AS STRING)
'*****************************************
' 显示字符
'*****************************************
STATIC Lc%
STATIC lDig() AS LONG
STATIC lHz() AS LONG
IF Lc = 0 THEN
Lc = 1
REDIM lDig(16, 38) AS LONG
REDIM lHz(32, 30) AS LONG
FOR I = 0 TO 29
FOR J = 0 TO 31
READ lHz(J, I)
NEXT
NEXT
FOR I = 0 TO 37
FOR J = 0 TO 15
READ lDig(J, I)
NEXT
NEXT
END IF
CONST digs = "PgDnUp0123456789:CoyrihtE-malu_w@.cQ()"
CONST Hzs = "零一二三四五六七八九十日初廿闰正国历年月农改变秋风万→←↑↓"
Cx = Lx
TT$ = nStr
WHILE TT$ <> ""
IF ASC(LEFT$(TT$, 1)) < 161 THEN
A$ = LEFT$(TT$, 1)
TT$ = MID$(TT$, 2, LEN(TT$))
Here = INSTR(digs, A$)
IF Here > 0 THEN
PUT (Cx, Ly), lDig(0, Here - 1), PSET
ELSE
LINE (Cx, Ly)-(Cx + 7, Ly + 15), 0, BF
END IF
Cx = Cx + 8
ELSE
A$ = LEFT$(TT$, 2)
TT$ = MID$(TT$, 3, LEN(TT$))
Here = INSTR(Hzs, A$)
IF Here > 0 THEN
PUT (Cx, Ly), lHz(0, (Here - 1) / 2), PSET
END IF
Cx = Cx + 16
END IF
WEND
END SUB
SUB sys.init '****** 初始化程序并获得数据 **********
SCREEN 12
PP 230, 50, "万年历 1920-2049 年"
PP 174, 70, "秋风 Copyright(C) 2004年 3月 14日"
PP 154, 90, "E-mail:untill_wwy@163.com QQ:160190416"
PP 200, 120, "日 一 二 三 四 五 六"
PP 184, 258, "农历: 年 月 日"
PP 184, 278, "国历: 年 月 日"
PP 176, 310, "PgDn PgUp 改变年 →←↑↓ 改变日"
END SUB
