如何在 AS/400 製作萬年曆？
Disclaimer:
Due to the time span covered by this Web site, code and utilities were
tested using various versions and releases of OS/400. PTF levels were
current as of the publication of the article. If you are using a different
release or PTF, the programs may perform differently. Similarly, articles
that use IBM's QUSRTOOL library may be invalidated by new releases
of the operating system. The QUSRTOOL library should be re-created
for each operating system update. It is the user's responsibility to determine
if the programs, procedures, and other information are accurate and
suitable for the user's computer installation. Always back up your files
and libraries before running any programs, and thoroughly test programs
and procedures before placing them into production.
The opinions expressed on this Web site are not necessarily those of
IIR Publications Inc. or the editors of its publications.
Midrange Computing is a registered trademark of IIR Publications Inc.
IBM and AS/400 are registered trademarks of International Business Machines.
All other product names are trademarked or copyrighted by their respective manufacturers.
***********************************************************************
* Readme *
***********************************************************************
* Midrange Computing Programs Associated With Article *
* *
* The Pop-up Calendar Window *
* *
* Published in the Sept 1998 Issue *
***********************************************************************
***** subroutine: "Browse" ***********************************
***** perform browse/prompt function ***************************
C Browse begsr
* find and set cursor location so cursor will stay at same position when
* screen is redisplayed
c Bin div 256 CsrRow
c mvr CsrCol
c eval *in77 = *on
* if prompt was requested on a "prompt capable" field, get window
c Select
c when csrfld = 'PRINTER'
c call 'WIN001RG'
c parm *blanks ReturnCode
c parm csrfld FileName
c parm *blanks PassCode
c if ReturnCode = '50'
c movel PassCode Printer
c endif
* browse date fields
c when csrfld = 'FROMDATE' or
c csrfld = 'TODATE'
c call 'CAL001RG'
c parm *blanks ReturnCode
c parm *zeros PassDate 6 0
c if ReturnCode = '50'
c if CsrFld = 'FROMDATE'
c movel PassDate FromDate
c endif
c if CsrFld = 'TODATE'
c movel PassDate ToDate
c endif
c endif
c endsl
csr endsr
*===============================================================
* To compile:
*
* CRTDSPF FILE(XXX/CAL001DF) SRCFILE(XXX/QDDSSRC)
*
*===============================================================
A DSPSIZ(24 80 *DS3) CHGINPDFT
A CA03 CA12
A R WINDOW
A WINDOW(9 45 12 30 *NOMSGLIN *NORSTC-
A SR)
A ROLLUP(95)
A ROLLDOWN(96)
A HEADING 30A O 1 1DSPATR(HI)
A COLOR(RED)
A 3 1' Sun Mon Tue Wed Thr Fri Sat'
A DSPATR(HI)
A WEEK1 30A O 4 1
A WEEK2 30A O 5 1
A WEEK3 30A O 6 1
A WEEK4 30A O 7 1
A WEEK5 30A O 8 1
A WEEK6 30A O 9 1
A 10 2'Key date, press Enter.....'
A DSPATR(HI)
A COLOR(BLU)
A KEYDAY 2Y 0B 10 29DSPATR(HI)
A CHECK(RZ)
A 41 DSPATR(PC)
A 41 ERRMSG('The day you have keyed is n-
A ot valid')
A 12 1'F3=Exit'
A COLOR(BLU)
A 12 9'F12=Previous'
A COLOR(BLU)
A 12 22'Page keys'
A COLOR(BLU)
A R DUMMY
A KEEP
A ASSUME
A 1 3' '
-----------------------------------------------------------------------
*===============================================================
* To compile:
*
* CRTRPGMOD MODULE(XXX/CAL001RG) SRCFILE(XXX/QRPGLESRC)
*
*===============================================================
fCAL001DF cf e workstn
* Month labels
d Mnt s 11 dim(12) ctdata perrcd(6)
* Weeks
d Wk0 s 4 dim(7)
*
d ds
d Week 1 180 dim(6)
d Week1 1 30
d Week2 31 60
d Week3 61 90
d Week4 91 120
d Week5 121 150
d Week6 151 180
*
d ds inz
d Maxdate 1 10d datfmt(*iso)
d Maxday 9 10 0
*
d ds inz
d InDate 1 10d datfmt(*iso)
d InYear 1 4 0
d InMonth 6 7 0
d InDay 9 10 0
*
d ds inz
d WorkDate 1 10d datfmt(*iso)
d WorkDay 9 10 0
*
d BaseDate s d inz(d'1901-01-01')
d Daylit s 2
d HoldYr s 4
d I s 2 0
d PassDate s 6 0
d ReturnCode s 2
d Tempfield s 7 0
d Today s d datfmt(*usa)
d Wk s 1 0
d X s 3 0
d Y s 3 0
*
d High c const(x'22')
d Normal c const(x'20')
c *entry plist
c parm ReturnCode
c parm PassDate
* Establish todays date
c *USA move *DATE Today
* Begin browse with date passed in, if available
c *YMD test(d) PassDate 68
c if *in68 = *off
c *YMD move PassDate Indate
c else
c move Today Indate
c endif
* Processing Loop
c dou *inKC = *on
c exsr Calendar
c exfmt Window
c eval *in41 = *off
* EOJ
c select
c when *inKC = *on
c move *zeros PassDate
c move '03' ReturnCode
c goto End
* Previous
c when *inKL = *on
c move *zeros PassDate
c move '12' ReturnCode
c goto End
c endsl
* Page Down
c if *in95 = *on
c Adddur 1:*M InDate
c exsr Calendar
c iter
c endif
* Page Up
c if *in96 = *on
c Subdur 1:*M InDate
c exsr Calendar
c iter
c endif
* Invalid day keyed
c if Keyday < 01
c or Keyday > Maxday
c eval *in41 = *on
c iter
c endif
* Fall through with correct date
c move KeyDay InDay
c *mdy move InDate PassDate
c move '50' ReturnCode
c leave
c enddo
*
c End tag
c eval *inlr = *on
*
***** subroutine: "Calendar" *************************************
*** display calendar for change of date **************************
csr Calendar begsr
* Build Heading
c move Inyear HoldYr
c Eval Heading = ' ' +
c %trim(Mnt(InMonth)) + ' ' +
c HoldYr
* Find maximum date for current month
c InDate AddDur 1:*M MaxDate
c Eval MaxDay = 01
c SubDur 1:*D MaxDate
*
c move InDate WorkDate
c clear Week
c clear Wk0
c eval Y = 1
*
c 1 do MaxDay X
c eval Workday = X
c if X = 1
c exsr Dowsr
c endif
c move X Daylit
c if X < 10
c movel ' ' Daylit
c endif
c move Daylit Wk0(i)
c movel Normal Wk0(i)
c if WorkDate = Today
c movel High Wk0(i)
c endif
c if I = 7
c movea Wk0 Week(y)
c move *blanks Wk0
c eval Y = Y + 1
c eval I = *zeros
c endif
c eval I = I + 1
c enddo
c movel Normal Wk0(i)
c movea Wk0 Week(y)
csr endsr
***** subroutine: "dowsr" **************************************
*** calculate day of the week from month/day/year ****************
csr Dowsr begsr
* Find day of the week...
* When index = 0, the day is Tuesday
* When index = 1, the day is Wednesday, and so on...
c WorkDate SubDur Basedate Tempfield:*D
c Div 7 Tempfield
c mvr I
c Eval I = (I + 3)
c If I > 7
c Eval I = (I - 7)
c EndIf
csr endsr
*
** NAMES OF MONTHS (MNT)
January February March April May June
July August September October November December
===============================
星期二, 10月 31, 2023
2000-03-07 如何在 AS/400 製作萬年曆？
訂閱：
張貼留言 (Atom)
沒有留言:
張貼留言