如何取得程式先後執行的順序(Calling Stack Information)？利用系統函數 _MATINVS2 即可。
File : QRPGLESRC
Member: CALLSTKR
Type : RPGLE
* The following ILE RPG program reads the invocation stack.
* No need to use MI, a system built-in MATINVS2 does the trick.
* Compile with DFTACTGRP(*NO)
D wPgm s 30
D tmpstr s 52
D wObj ds 60
D wObjLib 30
D wObjPgm 30
D wInvStk ds 32767
D wInvBytPrv 9b 0
D wInvBytAvl 9b 0
D wInvNbrEnt 9b 0
D wInvMrkCnt 9b 0
D pInvEnt s *
D wInvEnt ds 128 based(pInvEnt)
D 32
D pInvPgm *
D wInvNbr 9b 0
D wInvMec 1
D wInvTyp 1
D wInvMrk 9b 0
D wInvIns 9b 0
D wInvActGrp 9b 0
D wInvSusP *
D MatInvS pr extproc('_MATINVS2')
D xInvStk like(wInvStk)
D*GetPgmName pr 30
D GetPgmName pr 60
D xpPgm *
C callp MatInvS (wInvStk)
C eval pInvEnt = %addr(wInvStk) + 16
C do wInvNbrEnt
C* eval wPgm = GetPgmName (pInvPgm)
C* wPgm dsply
C eval wObj = GetPgmName (pInvPgm)
C eval tmpstr = %trim(wObjLib) + '/' +
C %trim(wObjPgm)
C tmpstr dsply
C eval pInvEnt = pInvEnt + %size(wInvEnt)
C enddo
C eval *inlr = *on
***********************************************************************************************
** Get Program Name, returns blank if domain violation (security level >= 40)
***********************************************************************************************
P GetPgmName b
D pi 60
D xpPgm *
D wMatTmp ds
D wMatBytPrv 9b 0
D wMatBytAvl 9b 0
D wMatPtrTyp 1
D wMatPtrCtxT 1
D wMatPtrCtxST 1
D wMatPtrCtx 30
D wMatPtrObjT 1
D wMatPtrObjST 1
D wMatPtrObj 30
D wMatPtrAut 2
D wMatPtrTgI 2
D wRtnStr s 60
D MatPtr pr extproc('_MATPTR')
D xTemplate like(wMatTmp)
D xPointer *
C callp MatPtr (wMatTmp : xpPgm)
c if wMatBytAvl > 0
C eval wRtnStr = wMatPtrCtx +
C wMatPtrObj
C return wRtnStr
C else
C eval wRtnStr = *blanks
C return wRtnStr
C endif
C *pssr begsr
C return *blanks
C endsr
P GetPgmName e
星期二, 10月 31, 2023
2001-06-20 如何取得程式先後執行的順序(Calling Stack Information)？利用系統函數 _MATINVS2 即可。
2001-06-18 如何於執行 SQL/400 查詢指令結果中加入最後一行 Total line 的功能？
如何於執行 SQL/400 查詢指令結果中加入最後一行 Total line 的功能？
1. STRSQL
2.
Select 'Item' As RowType,
PartId,
Price
From Part
Union
Select 'Total' As RowType,
0 As PartId,
Sum( Price ) As Price
From Part
Order By RowType,
PartId
3. PartID 是數字性欄位，若您的欄位是文字性，ＵＮＩＯＮ 後之
0 As PartId
請改成
'0' As PartId
2001-06-13 如何加入告示板移動式訊息(Scrolling Message)於應用軟體中？
如何加入告示板移動式訊息(Scrolling Message)於應用軟體中？
File : QDDSSRC
Member: BILLBOARDD
Type : DSPF
A DSPSIZ(24 80 *DS3)
A MSGLOC(24)
A PRINT
A CA03(03 'EXIT PROGRAM')
A R WAITMSG
A ASSUME
A KEEP
A OVERLAY
A FRCDTA
A @MSG 79A O 24 2
A DSPATR(HI)
A 22 DSPATR(RI)
A 22 COLOR(GRN)
A R DUMMY ASSUME
A 1 3' '
File : QRPGLESRC
Member: BILLBOARDR
Type : RPGLE
F*****************************************************************
F* *
F* OPTION BILLBOARD *
F* *
F*****************************************************************
F* *
F* BILLBOARDR- DISPLAY A MESSAGE IN THE MESSAGE LINE AS A *
F* BILL BOARD *
F* *
F* BY - Vengoal Chang *
F* *
F*****************************************************************
F* *
F* FILES USED: *
F* BILLBOARDD- DISPLAY FIUE *
F* FORMATS - DATAFOOT, WAITMSG *
F* *
F*****************************************************************
F*
FBILLBOARDDO E WORKSTN INFDS(WORKS)
D*
D CMD1 S 13 DIM(1) CTDATA PERRCD(1)
D NOTE S 79 DIM(1) CTDATA PERRCD(1)
D OP# S 1 DIM(160)
D I S 2 0
*
C*
C*----------------------------------------------------------------
C* @TIMES -> repeat display scrolling message number times
C *ENTRY PLIST
C PARM @NOTE 79
C PARM @TIMES 2 0
C*
C* EXECUTE SUBROUTINE OPTBB
C*
C Eval NOTE = @NOTE
C For I = 1 to @TIMES
C EXSR OPTBB
C EndFor
C MOVE '1' *INLR
C RETURN
C*
C*----------------------------------------------------------------
C* OPTION BILLBOARD DISPLAY MESSAGE ROUTINE
C*----------------------------------------------------------------
C*
C OPTBB BEGSR
C CLEAR OP#
C Z-ADD 13 LEN1 15 5
C MOVE *BLANKS @MSG 79
C MOVEL NOTE(1) @MSG
C MOVEA @MSG OP#(81)
C 1 DO 81 X 2 0
C MOVEA OP#(X) @MSG
C*
C* DO LOOP TO SLOW DOWN THE DISPLAY MESSAGE
C*
C 1 DO 30000 Y 5 0
C END
C WRITE WAITMSG
C END
C MOVE '1' *IN22
C WRITE WAITMSG
C*
C* CALL 'QCMDEXC' WITH THE CLP COMMAND DLYJOB FOR 3 SECONDS
C*
C CALL 'QCMDEXC'
C PARM CMD1
C PARM LEN1
C MOVE '0' *IN22
C CLEAR OP#
C MOVEA @MSG OP#(81)
C 1 DO 81 X
C MOVEA OP#(X) @MSG
C*
C* DO LOOP TO SLOW DOWN THE DISPLAY MESSAGE
C*
C 1 DO 30000 Y
C END
C MOVE '1' *IN22
C WRITE WAITMSG
C END
C MOVE '0' *IN22
C MOVE *BLANKS @MSG
C ENDSR
C*----------------------------------------------------------------
**
DLYJOB DLY(3)
**
File : QDDSSRC
Member: BILLBOARDT
Type : RPGLE Sample Program
F*****************************************************************
F* *
F* OPTION BILLBOARD Sample Program *
F* *
F*****************************************************************
F*
D NOTE S 79 inz('This is Scrolling Message!')
D
C Eval @NOTE = NOTE
C Call 'BILLBOARDR'
C PARM @NOTE 79
C PARM 2 @TIMES 2 0
C Move '1' *InLr
C*
2001-06-04 如何於ＣＬＰ中取得 AS/400 處理器屬於 IBM 哪一個 Group ?
如何於ＣＬＰ中取得 AS/400 處理器屬於 IBM 哪一個 Group ?
File : QCLSRC
Member: RTVPRCGRPC
Type : CLP
PGM
DCL VAR(&RESULT) TYPE(*CHAR) LEN(64)
DCL VAR(&RSTLEN) TYPE(*CHAR) LEN(4)
DCL VAR(&FORMAT) TYPE(*CHAR) LEN(8) +
VALUE('PRDR0100')
DCL VAR(&OSINFO) TYPE(*CHAR) LEN(27) +
VALUE('*OPSYS *CUR 0000*CODE ')
DCL VAR(&ERRCDE) TYPE(*CHAR) LEN(4)
DCL VAR(&RCVR) TYPE(*CHAR) LEN(64)
DCL VAR(&RCVRLEN) TYPE(*CHAR) LEN(4) +
VALUE(X'00000040')
DCL VAR(&RCVRFMT) TYPE(*CHAR) LEN(8) +
VALUE(LICR0200)
DCL VAR(&PRDID) TYPE(*CHAR) LEN(17) +
VALUE(' 5050')
DCL VAR(&PRDFMT) TYPE(*CHAR) LEN(8) VALUE(LICP0100)
DCL VAR(&EC) TYPE(*CHAR) LEN(4) VALUE(X'00000000')
DCL VAR(&PRCGRP) TYPE(*CHAR) LEN(64)
CHGVAR VAR(%BIN(&RSTLEN 1 4)) VALUE(64)
CHGVAR VAR(%BIN(&ERRCDE 1 4)) VALUE(0)
CALL PGM(QSYS/QSZRTVPR) PARM(&RESULT &RSTLEN +
&FORMAT &OSINFO &ERRCDE)
CHGVAR VAR(%SST(&PRDID 1 13)) VALUE(%SST(&RESULT 13 +
13))
CALL PGM(QLZARTV) PARM(&RCVR &RCVRLEN &RCVRFMT +
&PRDID &PRDFMT &EC)
CHGVAR VAR(&PRCGRP) VALUE(%SST(&RCVR 48 3))
SNDPGMMSG MSG('Your Processer Group is ' *CAT +
&PRCGRP *TCAT '.') MSGTYPE(*COMP)
ENDPGM
參考資料
1. IBM 使用上述程式所產生的 Processor Group 來訂定其系統程式收費等級。
2. 使用指令 WRKLICINF 亦可從結果畫面上得知 Processor Group.
3. AS/400e System Handbook http://www.redbooks.ibm.com/abstracts/ga195486.html
4. AS/400e System Builder http://www.redbooks.ibm.com/abstracts/sg242155.html
2001-05-04 如何於ＲＰＧ中做 Hex(十六位元） to Char （字元）轉換？
如何於ＲＰＧ中做 Hex(十六位元） to Char （字元）轉換？
File : QRPGLESRC
Member: CVTHEXCHR
Type : RPGLE
h debug dftactgrp(*no) actgrp('QILE') bnddir('QC2LE')
* dbgview(*list)
* The following are the C defintions for the MI function cvtch
* - refer to the MI Library Reference on the ILE C bookshelf for f
* void cvtch (_SPCPTR receiver,
* _SPCPTRCN source,
* int size););
D C2H Pr ExtProc('cvtch')
D RecPtrP * Value
D SrcPtrP * Value
D SizeP 10I 0 Value
D H2C Pr ExtProc('cvthc')
D RecPtrP * Value
D SrcPtrP * Value
D SizeP 10I 0 Value
D RecPtr S * INZ
D SrcPtr S * INZ
D OutStrD S 20 INZ
D InpStrD S 10 INZ('F1F2F3')
D Size S 10I 0 INZ
C Eval RecPtr=%Addr(OutStrD)
C Eval SrcPtr=%Addr(InpStrD)
C Eval Size=%len(%trim(InpStrD))
C CALLP C2H(RecPtr :
C SrcPtr :
C Size)
C Dump
C InpStrD Dsply
C OutStrD Dsply
C Movel(P) OutStrD InpStrD
C Eval OutStrD=*BLANKS
C Eval Size=%len(%trim(InpStrD))*2
C CALLP H2C(RecPtr :
C SrcPtr :
C Size)
C Dump
C InpStrD Dsply
C OutStrD Dsply
C SetOn LR
2001-04-24 使用 RPG 程式中 PSDS資料結構及 Chain OPCODE 之 Error(Low) Indicator 處理 Record Lock 問題
使用 RPG 程式中 PSDS資料結構及 Chain OPCODE 之 Error(Low) Indicator 處理 Record Lock 問題
*****************************************************************
* FILE: QDDSSRC
* MEMBER: RCDLOCKD DISPLAY MESSAGE WINDOW
* TYPE : DSPF
A*----------------------------------------------------------------
A* WINDOW TO SIGNAL LOCKED RECORD
A*----------------------------------------------------------------
A R W1
A OVERLAY
A WINDOW(15 1 4 76)
A WDWBORDER((*DSPATR RI) (*CHAR ' -
A '))
A*
A 1 35'ATTENTION :' DSPATR(RI)
A MSG 76 O 3 1 DSPATR(HI)
A*
A*----------------------------------------------------------------
A R RCDDUMMY
A KEEP ASSUME
A 1 3' '
*****************************************************************
* FILE: QRPGLESRC
* MEMBER: RCDLOCKR RETRIEVE RECORD LOCK MESSAGE SAMPLE
* TYPE : RPGLE
*
*****************************************************************
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
FFilea01l uf e k disk
fRcdLockd cf e workstn
* . . . . . . .
* . . . . . . .
* . . . . . . .
* . . . . . . .
* Program status data structure --------------
D SDS
D ExcpData 91 170
*----------------------------------------------------------------
* . . . . . . . you can use the Error Indicator *In98
* . . . . . . . or Use %Error(Filea) for error condition check
* . . . . . . .
*----------------------------------------------------------------
C dou *in99 = *off
C Key1 chain Filea 9998
C if *in98 = *on
C* if %error(filea)
C eval msg = %subst(ExcpData : 1 : 76)
C exfmt w1
C endif
C enddo
C*
* . . . . . . .
* . . . . . . .
2001-04-10 如何於 RPG 中取得指定日期為星期幾 ?
如何於 RPG 中取得指定日期為星期幾 ?
File : QRPGLESRC
Member: DayOfWeekR
Type : RPGLE
H DFTACTGRP(*NO)
D DateMDY S D datfmt(*mdy)
D DateAlpha S 8 Inz
D Output S 50 Inz
*
D ds
D TimeDate 14 0
D Time60 6 0 overlay(TimeDate: 1)
D Date80 8 0 overlay(TimeDate: 7)
*
D DayofWeekA S 9 DIM(7) CTDATA PERRCD(1)
*
D Days S 10I 0
D DayofweekN S 10I 0
D datefmt S 10 inz('MM/DD/YY')
*
* Feedback code data structure for CEE API
D fc DS
D sev 5I 0
D msgno 5I 0
D flags 1
D facid 3
D isi 10I 0
*
C *entry Plist
C Parm InputDate 10
*
*----------------------------------------------------*
* Get the current time *
*----------------------------------------------------*
C Time TimeDate
*
C *usa Move Date80 DateMDY
C Movel DateMDY DateAlpha
c Eval Output = 'Today is ' + DateAlpha
C Output DSPLY
* Convert Date to Lilian Format
C CallB(D) 'CEEDAYS'
C parm DateAlpha
C parm datefmt
C parm Days
C parm fc
C Eval Output = 'Today"s Lilian date is ' +
C %trim(%editc(Days : 'Z'))
C Output DSPLY
*
* Calculate Day of Week from Lilian Date
C CallB 'CEEDYWK'
C parm Days
C parm DayOfweekN
*
* For the day of week, 1 indicates Sunday, 2 indicates Monday, ...,
* 7 indicates Saturday.
C Eval Output = 'Today is ' +
C DayofWeekA(DayofWeekN)
C Output DSPLY
*
* Caculate Inputdate
c Eval Output = 'InputDate is ' + InputDate
C Output DSPLY
* Convert Date to Lilian Format
C CallB(D) 'CEEDAYS'
C parm InputDate
C parm 'MM/DD/YYYY' datefmt
C parm Days
C parm fc
C Eval Output = 'InputDate Lilian date is ' +
C %trim(%editc(Days : 'Z'))
C Output DSPLY
*
* Calculate Day of Week from Lilian Date
C CallB 'CEEDYWK'
C parm Days
C parm DayOfweekN
*
* For the day of week, 1 indicates Sunday, 2 indicates Monday, ...,
* 7 indicates Saturday.
C Eval Output = 'Inputdate Falls in ' +
C DayofWeekA(DayofWeekN)
C Output DSPLY
*
C Eval *InLR = *On
**
Sunday
Monday
Tuesday
Wednesday
Thursday
Friday
Saturday
參考資訊
1. Convert Date to Lilian Format (CEEDAYS) API
http://publib.boulder.ibm.com/cgi-bin/bookmgr/BOOKS/qb3amm03/4.4
2. Calculate Day of Week from Lilian Date (CEEDYWK) API
http://publib.boulder.ibm.com/cgi-bin/bookmgr/BOOKS/qb3amm03/4.3
3. Usage: CRTBNDRPG dftactgrp(*no)
4. Example : CALL DAYOFWEEKR '03/10/2001'
2001-04-10 如何於 CL 中取得指定日期為星期幾 ?
如何於 CL 中取得指定日期為星期幾 ?
FILE : QCLSRC
Member:DayOfWeeKC
Type: CLLE
PGM (&Date)
DCL &Date *Char 10
DCL &LDateB *Char 4 /* Binary */
DCL &LDateN *Dec 15 0 /* Decimal*/
DCL &DAYARRAY *CHAR 63 +
('Sunday Monday Tuesday +
WednesdayThursday Friday Saturday ')
DCL &IndexB *Char 4 /* Binary */
DCL &IndexN *Dec 15 0 /* Decimal*/
DCL &Start *Dec 15 0 /* Decimal*/
DCL &DayOfWeek *Char 9
DCL &Msg *Char 100
DCL &msgid *CHAR 7
DCL &msgf *CHAR 10
DCL &msgflib *CHAR 10
DCL &msgdta *CHAR 100
MONMSG CEE0000 EXEC(GOTO ERROR)
MONMSG CPF0000 EXEC(GOTO ERROR)
CALLPRC 'CEEDAYS' (&Date +
'MM/DD/YYYY' +
&LDateB +
*OMIT)
/* Convert to Dayofweek */
/* For the day of week, 1 indicates Sunday, 2 indicates Monday, */
/* 7 indicates Saturday. */
CALLPRC 'CEEDYWK' (&LDateB +
&IndexB +
*OMIT)
CHGVAR &IndexN %BIN(&IndexB)
CHGVAR &Start (&IndexN * 9 - 8)
CHGVAR &DayOfWeek %SST(&DayArray &Start 9)
SNDPGMMSG MSG(&DATE |> 'Falls on' |> &DAYOFWEEK |< +
'.') TOPGMQ(*PRV *PGMBDY)
Return
/*==================================================================*/
/* Error processing routine */
/*==================================================================*/
ERROR: RCVMSG MSGTYPE(*LAST) +
MSGDTA(&msgdta) +
MSGID(&msgid) +
MSGF(&msgf) +
SNDMSGFLIB(&msgflib)
/* Prevent loop, just in case */
MONMSG CPF0000
SNDPGMMSG MSGID(&msgid) +
MSGF(&msgflib/&msgf) +
MSGDTA(&msgdta) +
MSGTYPE(*ESCAPE)
/* Prevent loop, just in case */
MONMSG CPF0000
ENDPGM
使用說明
1. CRTBNDCL (DayofWeekc) DFTACTGRP(*NO)
2. 使用方法：
CALL DayOfWeekC '04/09/2001'
2001-03-16 如何於程式中判斷 Subsystem 的狀態 ？
如何於程式中判斷 Subsystem 的狀態 ？
/***********************************************************************/
/* */
/* RTVSBSSTS command 的使用範例程式 CLP : RTVSBSSTSC */
/* */
/* 呼叫這隻程式並且傳 subsystem 名稱及 libary 名稱當參數. */
/* 這隻程式會顯示 subsystem 是否啟動及有多少 Jobs 在此 subsyste中執行 */
/* */
/***********************************************************************/
PGM PARM(&NAME &LIB)
DCL VAR(&NAME) TYPE(*CHAR) LEN(10)
DCL VAR(&LIB) TYPE(*CHAR) LEN(10)
DCL VAR(&STATUS) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBSN) TYPE(*DEC) LEN(7 0)
DCL VAR(&JOBSC) TYPE(*CHAR) LEN(7)
RTVSBSSTS SBSNAME(&LIB/&NAME) STATUS(&STATUS) +
#ACTJOBS(&JOBSN)
CHGVAR VAR(&JOBSC) VALUE(&JOBSN)
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
MSGDTA('Subsystem: ' *CAT &NAME *BCAT ' +
Library: ' *BCAT &LIB *BCAT ' Status: ' +
*BCAT &STATUS *BCAT ' #ActiveJobs:' +
*BCAT &JOBSC) TOMSGQ(*TOPGMQ) MSGTYPE(*COMP)
ENDPGM
*===============================================================
*
* Program: RTVSBSSTSR - CPP for Retrieve Subsystem Status
*
* Type : RPGLE
*
* Purpose: When passed the name of a subsystem, return parms
* showing *ACTIVE/*INACTIVE and the number of jobs
*
*
*===============================================================
*---------------------------------------------------------------------
* Parameters
*---------------------------------------------------------------------
d PSbsLib s 20
d PStatus s 10
d P#jobs s 7 0
*---------------------------------------------------------------------
* Miscellaneous variables and structures
*---------------------------------------------------------------------
d arcvr ds 80
d aStatus 29 38
d a#jobs 73 76B 0
d arcvrlen s 4b 0 inz(80)
d aformat s 8 inz('SBSI0100')
d aqualname s 20
d aerror s 10
d NotFound c Const('*NOTFOUND')
*---------------------------------------------------------------------
*
* Parameter List
*
*---------------------------------------------------------------------
c *Entry PList
c Parm PSbsLib
c Parm PStatus
c Parm P#Jobs
*---------------------------------------------------------------------
*
* Mainline
*
*---------------------------------------------------------------------
c eval aqualname = PsbsLib
c CALL 'QWDRSBSD'
c PARM arcvr
c PARM arcvrlen
c PARM aformat
c PARM aqualname
c PARM aerror
c if aStatus = *blanks
c eval PStatus = NotFound
c eval P#Jobs = *zero
c else
c
c eval PStatus = AStatus
c eval P#Jobs = A#jobs
c endif
c eval *inlr = *on
c return
/*==============================================================*/
/* */
/* Command: RTVSBSSTS -- RETRIEVE SUBSYSTEM STATUS */
/* */
/* Type : CMD */
/* */
/*==============================================================*/
RTVSBSSTS: CMD PROMPT('Retrieve Subsystem Status')
PARM KWD(SBSNAME) TYPE(SBSNAMLIB) MIN(1) +
PROMPT('Subsystem')
PARM KWD(STATUS) TYPE(*CHAR) LEN(10) RTNVAL(*YES) +
PROMPT('Subsystem Status (Char 10)')
PROMPT('Subsystem Status (Char 10)')
PARM KWD(#ACTJOBS) TYPE(*DEC) LEN(7 0) +
RTNVAL(*YES) PROMPT('# Active jobs (Dec 7 +
0)')
SBSNAMLIB: QUAL TYPE(*NAME) LEN(10) MIN(1)
QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) +
SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library')
安裝步驟：
1. CRTBNDRPG PGM(lib/RTVSBSSTSR) SRCFILE(lib/QRPGLESRC) SRCMBR(RTVSBSSTSR)
2. CRTCMD CMD(lib/RTVSBSSTS) PGM(lib/RTVSBSSTSR) ALLOW(*IPGM *BPGM)
3. CRTCLPGM PGM(lib/RTVSBSSTSC) SRCFILE(lib/QCLSRC) SRCMBR(RTVSBSSTSC)
4. 於命令列下 ==> CALL RTVSBSSTSC ('QINTER' '*LIBL')
2001-03-16 如何於 RPG IV 中直接取得系統資訊 ?
如何於 RPG IV 中直接取得系統資訊 ?
FILE : QRPGLESRC
Member: RTVOSVERR
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
H BNDDIR('QC2LE') DFTACTGRP(*NO) ACTGRP(*CALLER)
* dbgview(*list)
DsndMsg pr
D msgText 80 const
D matmatr PR EXTPROC('matmatr')
D attributes * VALUE
D attrLen 5I 0 VALUE
* Reference from QSYSINC/MIH(MATAMATR)
D machineAttributes...
D DS INZ
D MMTR_Template_Size...
D 10I 0
D MMTR_Bytes_Used...
D 10I 0
D MMTR_VPD 4096
* Reference from QSYSINC/MIH(MATAMATR)
* typedef struct _MMTR_012C_T { /* Vital Product Data */
D VPDOffsets DS INZ
D vRes1 8
D vMemOff 10i 0
D vPrcOff 10i 0
D vColOff 10i 0
D vCecOff 10i 0
D vPnlOff 10i 0
D vRes2 12
D vMemInstalled 5i 0
D vMemRequired 5i 0
* char reserved3[12]; @A3C */
* _MEM_VPD_T Mem_Array[16]; /* 1024 bytes memory info */
* _PROC_VPD_T Proc_Array[16]; /* 1280 bytes processor info */
* _COL_VPD_T Col_Array[2]; /* 1=>reserved 2=>columis @A2C */
* _CEC_VPD_T CEC_Info;
* _PANEL_VPD_T Panel_Info;
* } _MMTR_012C_T;
* Reference from QSYSINC/MIH(MATAMATR)
* typedef struct _CEC_VPD_T { /* VPD Info */
d cecVPD DS INZ
d cCEC_read 4
d cManufacturin 4
d creserved1 4
d cType 4
d cModel 4
d cPseudo_Model 4
d cGroup_Id 4
d creserved2 4
d cSys_Type_Ext 1
d cFeature_Code 4
d cSerial_No 10
d creserved3 1
* } _CEC_VPD_T;
* typedef struct _PANEL_VPD_T { /* panel info */
d panelVPD DS INZ
d preserved1 2
d pPanel_Type 4
d pModel 3
d pPart 12
d preserved2 4
d pManufacturin 4
d pROS_Part 12
d pROS_Card 10
d pROS_ID 1
d pROS_Flag 1
d pROS_Fix 1
d pSerial_No 10
* } _PANEL_VPD_T;
D $MMTR_SERIAL_ S 5I 0 INZ(4)
* Reference from QSYSINC/MIH(MATAMATR)
D $MMTR_VPD_ S 5i 0 INZ(x'012c')
D prErrStruc DS inz
D prErrSSize 10i 0 inz(%len(prErrStruc))
D PrErrSUse 10i 0
D prErrSmsgID 7
D prErrSResrv 1
D prErrSData 80
d prRcvr s 128
d prRcvrLen s 10i 0 inz(%size(prRcvr))
d prFormat s 8 inz('PRDR0100')
d prPrdInfo s 27 inz('*OPSYS *CUR 0000*CODE ')
d prErr s like(prErrStruc)
d prRelease s 6
* /*-- get system info --*/
C EVAL MMTR_Template_Size = %SIZE(machineAttributes)
C CALLP matmatr( %ADDR(machineAttributes) :
C $MMTR_VPD_ )
* /*-- get OS/400 version --*/
c eval VPDOffsets = %subst(MMTR_VPD:
c 1:
c %len(VPDOffsets))
c eval cecVPD = %subst(MMTR_VPD:
c vCecOff-7:
c %len(cecVPD))
c eval panelVPD = %subst(MMTR_VPD:
c vPnlOff-7:
c %len(panelVPD))
C eval prErr = prErrStruc
c call 'QSZRTVPR'
c parm prRcvr
c parm prRcvrLen
c parm prFormat
c parm prPrdInfo
c parm prErr
C eval prErrStruc = prErr
C eval prRelease = %subst(prRcvr: 20: 6)
c callp sndMsg('Type ' + %trim(cType) +
c ' model ' + %trim(cModel) +
c ' prc grp ' + %trim(cGroup_ID) +
c ' fc ' + %trim(cFeature_Code) +
c ' serial ' + %trim(cSerial_No) +
c ' ' + %trim(
c %editc(vMemInstalled :
c 'Z')) + ' meg' +
c ' rel ' + %trim(prRelease)
c )
C eval *InLr = *on
C return
PsndMsg b
DsndMsg pi
D inpText 80 const
* Send message API parameters
D msgID s 7 inz('CPF9898')
D msgFil s 20 inz('QCPFMSG *LIBL ')
D msgData s like(inpText)
D msgDataLen s 10i 0 inz(%size(msgData))
D msgType s 10 inz('*INFO')
D msgStackEnt s 10 inz('*')
D msgStackCnt s 10i 0 inz(3)
D msgKey s 4
D msgErrStruc s like(ErrStruc)
* API error structure
D errStruc DS inz
D errSSize 10i 0 inz(%len(errStruc))
D errSUse 10i 0
D errSmsgID 7
D errSResrv 1
D errSData 80
C eval msgData = inpText
C eval msgErrStruc = errStruc
C Call 'QMHSNDPM'
C Parm msgID
C Parm msgFil
C Parm msgData
C Parm msgDataLen
C Parm msgType
C Parm msgStackEnt
C Parm msgStackCnt
C Parm msgKey
C Parm msgErrStruc
C Eval errStruc = msgErrStruc
PsndMsg e
參考資訊
?* -----------------------------------------------------------------------------------*
?* The program perform retrieving OS Version information *
?* and use two system API as following: *
?* *
?* 1.MI Library Reference : Materialize Machine Attributes (MATMATR) *
?* http://publib.boulder.ibm.com/cgi-bin/bookmgr/BOOKS/QBJADR00/1.63 *
?* Data structure refered from QSYSINC/MIH(MATAMATR) *
?* *
?* 2.Retrieve Product Information (QSZRTVPR) API *
?* http://publib.boulder.ibm.com/pubs/html/as400/v4r5m1/ic2924/info/apis/qszrtvpr.htm *
?* *
?*------------------------------------------------------------------------------------*
2001-03-02 如何於系統中產生唯一的辨認碼（UUID）？
如 何於系統中產生唯一的辨認碼（UUID）？
FILE: QRPGLESRC
Member: GENUUIDR
Type: RPGLE
H Option( *NoSrcStmt ) DftActGrp( *No )
**
D UUID_template Ds
D UtBytPrv 10u 0 Inz( %Size( UUID_template ))
D UtBytAvl 10u 0
D 8a Inz( *Allx'00' )
D UUID 16a
**
D GenUuid PR ExtProc('_GENUUID')
D UUID_template * Value
**
C Callp GenUuid( %Addr( UUID_template ))
**
C 'UUID' DSPLY
C UUID DSPLY
C Return
**
1. 描述 UUID 產生方式的文件，可用於交易編號知產生，在同一系統之中絕對不重複。
http://www.ics.uci.edu/~ejw/authoring/uuid-guid/draft-leach-uuids-guids-01.txt
2. 此範例是呼叫 AS/400 MI 函數而產生的。
3. Compiled : CRTBNDRPG GENUUIDR
4. Usage : Call GENUUIDR
5. Output : UUID 是十六進制的文字，所以畫面顯示會有亂碼或特殊顏色。
2001-02-06 如何於ＲＰＧ中判斷 Batch 或 Interactive Job -- INTERACTR
如 何於ＲＰＧ中判斷 Batch 或 Interactive Job -- INTERACTR
FILE：QRPGLESRC
MEMBER Type：RPGLE
H NoMain
D pInteractive PR N
D DummyPrm 1 Options( *Omit )
P pInteractive B Export
D pInteractive PI N
D DummyPrm 1 Options( *Omit )
* Local variables
D RetdInfDs DS
D 4
D 10I 0 Inz( %Size( RetdInfDs ) )
D RiJobType 61 61
D RiTypeInteractive...
D C 'I'
D LenRetdInf S 10I 0 Inz( %Size( RetdInfDs ) )
D FmtName S 8 Inz( 'JOBI0100' )
D QlJobName S 26 Inz( '*' )
D IntJobId S 16 Inz( *Blank )
C Call 'QUSRJOBI'
C Parm RetdInfDs
C Parm LenRetdInf
C Parm FmtName
C Parm QlJobName
C Parm IntJobId
C If RiJobType = RiTypeInteractive
C Return *On
C Else
C Return *Off
C EndIf
P pInteractive E
安裝及使用說明
a) 將 INTERACT 上傳至 112 bytes 長度的 source physical file.
並將上傳的 member 命名為 INTERACT 且其 PDM type 為 RPGLE.
b) 在 PDM 中使用選項 15 編譯 INTERACT 成為一模組物件.
c) 在 Command Line 下 command 產生服務程式（Service Program）：
CrtSrvPgm SrvPgm( INTERACT ) Export( *All ) ActGrp( WhateverYouWant )
要於 RPG IV 程式中使用這個服務程式，請參照下列步驟：
a) 在你的原始檔 D-specs 中要包含下列程序的 prototype（原型）：
D pInteractive PR N
D DummyPrm 1 Options( *Omit )
如果你希望這個程序被使用於多個程式中，你可以考慮使用 /Copy member 來宣告原型.
b) 下列示範你自己的程式如何於 C-specs 中呼叫程序 INTERACT ：
C If pInteractive( *Omit )
C 'Interactive' Dsply DummyVar
C EndIf
C If Not pInteractive( *Omit )
C 'Batch' Dsply
C Endif
c) 在 PDM 中使用選項 15 編譯 自己的程式 成為一模組物件.
d) 在 Command Line 下 command 產生你自己的程式
（底下範例是假設你的程式是單一的程式，也就是單一模組 MYPGM）：
CrtPgm MyPgm Module( MYPGM ) BndSrvPgm( INTERACT ) ActGrp( Whatever )
2001-01-18 如何計算依指定日期計算該指定日期之ＷＥＥＫ ＮＯ？
2001-01-18 如何計算依指定日期計算該指定日期之ＷＥＥＫ ＮＯ？
QRPGLESRC WEEKNUMR RPGLE
*--------------------------------------------------------------*
* Vengoal Chang Development Resource 2001.01 *
* *
* \\\\\\\ *
* ( o o ) *
*-------------------oOO----(_)----OOo--------------------------*
* *
* System name . . . : Technical Support *
* Program name . . . : WEEKNUMR *
* Text . . . . . . . : Caculate ISO 8601 Week number *
* *
* Author . . . . . . : Vengoal Chang *
* Description. . . . : ISO 8601 Week number test *
* *
* ooooO Ooooo *
* ( ) ( ) *
*-----------------( )-------------( )----------------------*
* (_) (_) *
* *
* Create method : *
* CRTRPGMOD MODULE(WEEKNUMR) *
* *
*--------------------------------------------------------------*
H NoMain
* Prototypes
D DayOfWk PR 1P 0
D InpDate D Value
D WkNum PR 2P 0
D InpDate D
* = * = * = * = * = * = * = * = * = * = * = * = * = * = * =
* DayOfWk - Returns day of week where Monday = 0
P DayOfWk B Export
D DayOfWk PI 1P 0
D InpDate D Value
* Local variables
D SomeMonday S D Inz( D'1999-03-01' )
D ElpsdDays S 11P 0
D WkNum S 11P 0
D RetDayOfWk S 1P 0
* Calculate day of week
C InpDate SubDur SomeMonday ElpsdDays:*D
C ElpsdDays Div 7 WkNum
C MvR RetDayOfWk
C If RetDayOfWk < *Zero
C Return RetDayOfWk + 7
C* Eval RetDayOfWk = RetDayOfWk + 7 + 1
C Else
C Return RetDayOfWk
C* Eval RetDayOfWk = RetDayOfWk + 1
C EndIf
C* Return RetDayOfWk
P DayOfWk E
* = * = * = * = * = * = * = * = * = * = * = * = * = * = * =
* WkNum - Returns the ISO 8601 day of week
* http://www.cl.cam.ac.uk/~mgk25/iso-time.html
* Algorithm for Converting Gregorian Dates to ISO 8601 Week Date
* http://personal.ecu.edu/mccartyr/ISOwdALG.txt
P WkNum B Export
D WkNum PI 2P 0
D InpDate D
* Local variables
D DS
D Jan4 D Inz( D'1999-01-04' )
D J4Year 4S 0 Overlay( Jan4 )
D InpYear S 4S 0
D FirstMonday S D
D Jan4DayOfWk S 1P 0
D ElpsdDays S 11P 0
* Construct a date which is January 4 of the desired year
C Extrct InpDate:*Y InpYear
C Eval J4Year = InpYear
* Construct the first monday of the ISO year by subtracting the
* day of the week from the January 4 date.
C Eval Jan4DayOfWk = DayOfWk( Jan4 )
C Jan4 SubDur Jan4DayOfWk:*DFirstMonday
* If the input date is before the first monday of the current year
* then we must construct the first monday of the prior year
C If InpDate < FirstMonday
C Eval J4Year = J4Year - 1
C Eval Jan4DayOfWk = DayOfWk( Jan4 )
C Jan4 SubDur Jan4DayOfWk:*DFirstMonday
C EndIf
* To get the week number, subtract the first monday of the ISO
* year from the input date and divide by 7. Adding 1 to that
* result (since 0 actually means the first week) gives us
* the week number
C InpDate SubDur FirstMonday ElpsdDays:*D
C Return ( ElpsdDays / 7 ) + 1
P WkNum E
====================================================================
QRPGLESRC WEEKNUMRT RPGLE
*--------------------------------------------------------------*
* Vengoal Chang Development Resource 2001.01 *
* *
* \\\\\\\ *
* ( o o ) *
*-------------------oOO----(_)----OOo--------------------------*
* *
* System name . . . : Technical Support *
* Program name . . . : WEEKNUMRT *
* Text . . . . . . . : ISO 8601 Week number test *
* *
* Author . . . . . . : Vengoal Chang *
* Description. . . . : ISO 8601 Week number test *
* *
* ooooO Ooooo *
* ( ) ( ) *
*-----------------( )-------------( )----------------------*
* (_) (_) *
* *
* Create method : *
* CRTRPGMOD MODULE(WEEKNUMR) *
* CRTRPGMOD MODULE(WEEKNUMRT) *
* CRTPGM PGM(WEEKNUMRT) MODULE(WEEKNUMRT WEEKNUMR) *
* *
* Usage Sample : *
* Call WEEKNUMRT '2001-01-01' *
* *
*--------------------------------------------------------------*
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
D DS
D DateIso D
D Year 4 Overlay( DateIso )
D IsoDayOfWk S 1 0
D WKnumn S 2 0
D TempS S 50
D DayOfWk PR 1P 0
D InpDate D Value
D WkNum PR 2P 0
D InpDate D
C *entry plist
C parm DateIsoC 10
C Movel DateIsoC DateISO
*
* DayOfWk - Returns day of week where Monday = 0
* But ISO 8601 define Monday =1, Thuresday =2, ... Sunday =7.
* So need add 1 to IsoDayOfWk.
*
C Eval IsoDayOfWk = DayofWk(DateIso) + 1
C Eval WkNumn = WkNum(DateIso)
C Extrct DateIso:*Y Year
C Move WkNumn WkNumC 2
C Eval Temps = DateIsoC + ' ' + Year + '-W' +
C WkNumC +'-' +
C %trim(%Editc((IsoDayofWk):'Z'))
C TempS Dsply
C Eval *InLr = '1'
2000-12-26 如何將 CL SOURCE COMMENT 說明行加上顏色以加強說明重要性？
2000-12-26 如何將 CL SOURCE COMMENT 說明行加上顏色以加強說明重要性？
QCLSRC COLCLCMTC CLP
/*===================================================================*/
/* To compile: */
/* */
/* CRTCLPGM PGM(XXX/COLCLCMTC) SRCFILE(XXX/QCLSRC) + */
/* TEXT('COLOR CL COMMENT LINE') */
/* */
/*===================================================================*/
PGM
DCL VAR(&COL) TYPE(*CHAR) LEN(1) VALUE(X'28') /* +
Make color blue */
/* Normal Reverse Underline */
/* BLU 3A 3B 3E */
/* GRN 20 21 24 */
/* PNK 38 39 3C */
/* RED 28 29 2C */
/* TRQ 34 35 34 */
/* WHT 22 23 26 */
/* YLW 32 33 36 */
DCL VAR(&START) TYPE(*CHAR) LEN(2) VALUE('/*') +
/* Starting characters */
DCL VAR(&SPACE) TYPE(*CHAR) LEN(50) VALUE('This +
is comment color line') /* Blanks */
DCL VAR(&END) TYPE(*CHAR) LEN(2) VALUE('*/') /* +
Ending characters */
DCL VAR(&COMMENT) TYPE(*CHAR) LEN(55) /* Comment +
line */
CHKOBJ OBJ(CHANCY/QCLSRC) OBJTYPE(*FILE) MBR(COMMENT)
MONMSG MSGID(CPF9815) EXEC(DO)
ADDPFM FILE(CHANCY/QCLSRC) MBR(COMMENT) +
TEXT('Comment line for CLP') SRCTYPE(CLP)
ENDDO
CHGVAR VAR(&COMMENT) VALUE(&START *CAT &COL *CAT +
&SPACE *CAT &END)
OVRDBF FILE(QCLSRC) TOFILE(CHANCY/QCLSRC) MBR(COMMENT)
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'3A'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'20'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'38'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'28'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'34'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'22'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'32'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'3B'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'21'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'39'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'29'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'35'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'23'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'33'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'3E'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'24'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'3C'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'2C'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'34'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'24'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
CHGVAR %SST(&COMMENT 3 1) X'36'
CALL PGM(COLCLCMTR) PARM(&COMMENT)
DLTOVR FILE(QCLSRC)
ENDPGM
=====================================================================
QRPGSRC COLCLCMTR RPG
*==============================================================*
* To compile: *
* *
* CRTRPGPGM PGM(XXX/COLCLCMTR) SRCFILE(XXX/QRPGSRC) + *
* TEXT('COLOR CL COMMENT LINE') *
* *
*==============================================================*
FQCLSRC O E DISK
F QCLSRC KRENAMEMAINRC
******************************************************
C *ENTRY PLIST
C PARM COMM 55
C Z-ADD1 SRCSEQ
C MOVE *ZEROS SRCDAT
C MOVELCOMM SRCDTA P
C WRITEMAINRC
C MOVE *ON *INLR
2000-12-20 如何在一指定範圍內產生不重複的隨機變數？
2000-12-20 如何在一指定範圍內產生不重複的隨機變數？
QRPGLESRC RANDOMNUMR RPGLE
* Random numbers without duplicates
* Display list of unique random numbers
* Original: V5R1 RPGIV free format by Hans Boldt (boldt@ca.ibm.com)
* Modified: V4R4 RPGIV by Vengoal Chang
* CRTBNDRPG PGM(RANDOMNUMR) DFTACTGRP(*NO) BNDDIR(QC2LE)
H dftactgrp(*no) bnddir('QC2LE')
D NUMBER c 6
D LOVALUE c 1
D VALUES c 30
D rand pr 10i 0 extproc('rand')
D i s 10i 0
D num s 10i 0
D swap s 10i 0
D numbers s 10i 0 dim(VALUES)
D arr s 10i 0 dim(NUMBER)
D str s 50a varying
*/free // Initialize list of possible values
C for i = 1 to VALUES
C Eval numbers(i) = i + LOVALUE - 1
C endfor
*// Keep looping until we have enough unique numbers
C for i = 1 to NUMBER
C*// Compute random number in range i..VALUES
C eval num = %div(rand * (VALUES+1-i): 32768) + i
*// Swap numbers
C eval swap = numbers(i)
C eval numbers(i) = numbers(num)
C eval numbers(num) = swap
C endfor
*// Assign first 6 numbers to result array
C eval arr = numbers
*// What the heck, let's sort the list of numbers
C sorta arr
*// Show list of numbers
C for i = 1 to NUMBER
C eval str = str + %char(arr(i)) + ' '
C endfor
C str dsply
C eval *inlr = *on
2000-12-04 如何將數字文字轉成數字﹙ＩＢＭ版）
2000-12-04 如何將數字文字轉成數字﹙ＩＢＭ版）
QRPGLESRC RPGLE getNum_P Prototype
*---------------------------------------------------------
* getNum - procedure to read a number from a string
* and return a 30p 9 value
* Parameters:
* I: string - character value of number
* I:(opt) decComma - decimal point and digit separator
* I:(opt) currency - currency symbol for monetary amounts
* Returns: packed(30,9)
*
* Parameter details:
* string: the string may have
* - blanks anywhere
* - sign anywhere
* accepted signs are: + - cr CR ()
* (see examples below)
* - digit separators anywhere
* - currency symbol anywhere
* decComma: if not passed, this defaults to
* decimal point = '.'
* digit separator = ','
* currency: if not passed, defaults to ' '
*
* Examples of input and output (x means parm not passed):
*
* string | dec | sep | cursym | result
* ---------------+-----+-----+--------+------------
* 123 | x | x | x | 123
* +123 | x | x | x | 123
* 123+ | x | x | x | 123
* -123 | x | x | x | -123
* 123- | x | x | x | -123
* (123) | x | x | x | -123
* 12,3 | , | . | x | 12.3
* 12.3 | x | x | x | 12.3
* 1,234,567.3 | x | x | x | 1234567.3
* $1,234,567.3 | . | , | $ | 1234567.3
* $1.234.567,3 | , | . | $ | 1234567.3
* 123.45CR | x | x | x | -123.45
*
* Author: Barbara Morris, IBM Toronto Lab
* Date: March, 2000
*---------------------------------------------------------
D getNum pr 30p 9
D string 100a const varying
D decComma 2a const options(*nopass)
D currency 1a const options(*nopass)
===================================================================================
QRPGLESRC RPGLE GetNum Module
*<-----* module GETNUM start here ----->
H NOMAIN
* Copy prototype for procedure getNum
D/COPY GETNUM_P
p getNum b Export
D getNum pi 30p 9
D string 100a const varying
D decComma 2a const options(*nopass)
D currency 1a const options(*nopass)
* defaults for optional parameters
D decPoint s 1a inz('.')
D comma s 1a inz(',')
D cursym s 1a inz(' ')
* structure for building result
D ds
D result 30s 9 inz(0)
D resChars 30a overlay(result)
* variables for gathering digit information
* pNumPart points to the area currently being gathered
* (the integer part or the decimal part)
D pNumPart s *
D numPart s 30a varying based(pNumPart)
D intPart s 30a varying inz('')
D decPart s 30a varying inz('')
* other variables
D intStart s 10i 0
D decStart s 10i 0
D sign s 1a inz('+')
D i s 10i 0
D len s 10i 0
D c s 1a
* override defaults if optional parameters were passed
C if %parms > 1
C eval decPoint = %subst(decComma : 1 : 1)
C eval comma = %subst(decComma : 2 :1)
C endif
C if %parms > 2
C eval cursym = currency
C endif
* initialization
C eval len = %len(string)
* begin reading the integer part
C eval pNumPart = %addr(intPart)
* loop through characters
C do len i
C eval c = %subst(string : i : 1)
C select
* ignore blanks, digit separator, currency symbol
C when c = comma or c = *blank or c = cursym
C iter
* decimal point: switch to reading the decimal part
C when c = decPoint
C eval pNumPart = %addr(decPart)
C iter
* sign: remember the most recent sign
C when c = '+' or c = '-'
C eval sign = c
C iter
* more signs: cr, CR, () are all negative signs
C when c = 'C' or c = 'R' or
C c = 'c' or c = 'r' or
C c = '(' or c = ')'
C eval sign = '-'
C iter
* a digit: add it to the current build area
C other
C eval numPart = numPart + c
C endsl
C enddo
* copy the digit strings into the correct positions in the
* zoned variable, using the character overlay
C eval decStart = %len(result) - %decPos(result)
C + 1
C eval intStart = decStart - %len(intPart)
C eval %subst(resChars
C : intStart
C : %len(intPart))
C = intPart
C eval %subst(resChars
C : decStart
C : %len(decPart))
C = decPart
* if the sign is negative, return a negative value
C if sign = '-'
C return - result
* otherwise, return the positive value
C else
C return result
C endif
p e
===================================================================================
QRPGLESRC RPGLE
****************************************************************
*--------------------------------------------------------------*
* *
* Module Creation: CRTRPGMOD MODULE(library/GETNUMTEST) *
* SRCFILE(library/QRPGLESRC) *
* *
* Program Creation: CRTPGM PGM(library/GETNUMTEST) *
* MODULE(library/GETNUMTEST) *
* library/GETNUM) *
* *
****************************************************************
* Copy prototype for procedure getNum
D/COPY GETNUM_P
D res s like(getNum)
D msg s 52a
C *entry plist
C parm p 32
C parm dc 2
C parm c 1
C select
C when %parms = 1
C eval res = getNum(p)
C when %parms = 2
C eval res = getNum(p : dc)
C when %parms = 3
C eval res = getNum(p : dc : c)
C endsl
C eval msg = '<' + %char(res) + '>'
C msg dsply
C return
2000-10-25 如何於ＲＰＧＩＶ中使用Ｃ函數產生亂數
□ Tips : 如何於ＲＰＧＩＶ中使用Ｃ函數產生亂數
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
範例：利用Ｃ函數 SRAND 與 RAND 產生亂數
QRPGLESRC RANDR
* ------------------------------------------------------------- *
* Description| Program to Randomly generate a 4 digit *
* | number and dump the results. *
* | This is a prototype only. *
* ============================================================= *
* WARNING ! ! ! SPECIFIC COMPILATION ! ! ! WARNING *
* To compile this program properly you will have to use the *
* following option : *
* CRTBNDRPG DFTACTGRP(*NO) *
* BNDDIR(QC2LE) *
* This is to allow the called function 'rand' to be retrieved *
* from a non-RPG program library. *
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
H DFTACTGRP(*NO)
D SeedRandom PR 10I 0 ExtProc('srand')
D SeedP 10U 0 Value
D GetRandom PR 10I 0 ExtProc('rand')
* Regular numeric variables to receive result of random function.
D #Num1 S 5P 0
D #Num2 S 5P 0
D #Num3 S 5P 0
D #Num4 S 5P 0
* LongTime has a "Z" datatype, the 20 byte timestamp.
D TimeStampZ S Z
* From Program Status Data Structure
* Job Number, to be used to make a unique number in the data structure.
D MYPSDS SDS
D JOB_NUM 264 269S 0
* Alpha Time Stamp from the TIME Instruction in the "Z" type var.
D DSTimeStamp DS
D ASMil 21 26S 0
D AlphaTime 1 26A
**************************************************************************
*
* New Random with Time & Jobnumber combined as a seed.
*
C TIME TimeStampZ
C MOVE TimeStampZ AlphaTime
C TIME DATTIM 6 0
*
* Regular GetRandom with rand function
C CallP SeedRandom(JOB_NUM + DATTIM + ASMil)
C EVAL #num1 = GetRandom
C EVAL #num2 = GetRandom
C EVAL #num3 = GetRandom
C EVAL #num4 = GetRandom
**************************************************************************
*
C DUMP
C MOVE *ON *INLR
參考資料：
Interfacing RPG IV with the C language high-level math library
Converting from C prototypes to RPG prototypes callc.html
"C Library Ref." SC09-2119
"ILE C/400 Programmer’s Ref." SC09-2070
"System API Ref. OS/400 UNIX-type APIs" SC41-4875
"MI Functional Ref." SC41-4810
"ILE C/400 Programmer’s Ref." SC09-2070
"ILE C/C++ MI Library Ref." V3R7
"OS/400 Sockets Programming V3R6" SC41-4422 (TCP/IP)
"CPA Toolkit/400 Ref." SC41-4802
2000-10-04 如何於 RPG 或 RPGIV 中處理讀取檔案資料時所產生 的數字欄位, 是 Packed type 的數字錯誤(Decimal error)？
□ Tips : 如何於 ＲＰＧ 或ＲＰＧＩＶ中處理讀取檔案資料時所產生 的數字欄位
是 Packed type 的數字錯誤(Decimal error)？
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
1. ＲＰＧ 程式以 CRTRPGPGM PGM(XXXX)... IGNDECERR(*YES) Compiled
執行程式時若遇到讀取檔案資料時 數字錯誤，系統會自動以以零取代錯誤值，程式不
會被中斷。
2. ＲＰＧＩＶ程式於 H - Spec 中加入 FixNbr( *Zoned : *InputPacked ) 參數，
FixNbr( *Zoned )==> 系統會自動以以零取代錯誤值，程式不會被中斷。
FixNbr(*InputPacked)==> 系統會自動以以零取代錯誤值，程式會被中斷，並有錯
誤訊息 MCH1202 產生於 Joblog 。
FixNbr( *Zoned : *InputPacked )系統會自動以以零取代錯誤值，程式會被中斷，並
有錯誤訊息 MCH1202 產生於 Joblog 。
3. 使用 CPYF 命令，定義一與原檔案相同新的ＤＤＳ，但更改 packed 數字欄位
為 zoned 數字欄位，並建立一新的空檔案。下 Command :
CPYF FROMFILE(old-packed file) TOFILE(new-zoned file) FMTOPT(*MAP) ERRLVL(*NOMAX)
CPYF FROMFILE(new-zoned file) TOFILE(old-packed file) FMTOPT(*MAP) MBROPT(*REPLACE)
使用這個方法，你可以修復任何你想要的數值，不只是 0 而已，包含於 DDS 中 DFT
關鍵字所設定的任何數值。
4. 使用下列程式，其中pack1，pack2，pack30 是檔案中 packed 數字欄位名稱，
請修改成你自己檔案名稱及檔案中的數字欄位名稱
Ffile uf f 22 disk
D ds e ds extname(file)
D fixPacked pr
D addr * value
D len 10i 0 value
D changed 1a
D doUpdate s 1a inz('0')
C read file ds lrlr
C dow not *inlr
C callp fixPacked(%addr(pack1)
C : %size(pack1)
C : doUpdate)
C callp fixPacked(%addr(pack2)
C : %size(pack2)
C : doUpdate)
C callp fixPacked(%addr(pack30)
C : %size(pack30)
C : doUpdate)
C if doUpdate = '1'
C update file ds
C endif
C read file ds lrlr
C enddo
P fixPacked b
D fixPacked pi
D addr * value
D len 10i 0 value
D changed 1a
D inputVal s 16a based(addr)
* Valid values for a byte of a packed field except the final byte
D okFirst C x'-
D 00010203040506070809-
D 10111213141516171819-
D 20212223242526272829-
D 30313233343536373839-
D 40414243444546474849-
D 50515253545556575859-
D 60616263646566676869-
D 70717273747576777879-
D 80818283848586878889-
D 90919293949596979899-
D '
D* Valid values for the final byte of packed field
D okLast c x'-
D 0a1a2a3a4a5a6a7a9a9a-
D 0b1b2b3b4b5b6b7b9b9b-
D 0c1c2c3c4c5c6c7c9c9c-
D 0d1d2d3d4d5d6d7d9d9d-
D 0e1e2e3e4e5e6e7e9e9e-
D 0f1f2f3f4f5f6f7f9f9f-
D '
D* Area for checking the first len-1 bytes of the packed field
D checkFirst s 16a
D lastByte s 1a
* Check the first n-1 bytes
C if len > 1
C eval checkFirst = okFirst
C eval %subst(checkFirst : 1 : len - 1) =
C %subst(inputVal : 1 : len - 1)
C okFirst check checkFirst 10
C 10 exsr bad
C endif
* Check the last byte
C eval lastByte = %subst(inputVal : len : 1)
C okLast check lastByte 10
C 10 exsr bad
C return
* Subroutine to put a packed zero in the parameter
C bad begsr
C eval %subst(inputVal : 1 : len) = *allx'00'
C eval %subst(inputVal : len : 1) = x'0f'
C eval changed = '1'
C return
C endsr
P fixPacked e
2000-10-04 如何利用Subfile message 顯示訊息？
□ Tips : 如何利用Subfile message 顯示訊息？
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
QDDSSRC SFLMSGD
A CA03
A*-------------------------------------*
A R HED01
A*-------------------------------------*
A 80 ALARM
A KEEP
A BLINK
A OVERLAY
A PUTOVR
A 1 2'SFLMSGD'
A 1 30'Subfile Message Test'
A 1 72DATE
A EDTCDE(Y)
A USER 10A O 2 2
A 2 72TIME
A EDTWRD(' : : ')
A 8 18'This is a test of subfile message -
A function '
A 21 67'Vengoal Chang'
A DSPATR(HI)
A*-------------------------------------*
A R SFLMSG SFL
A*-------------------------------------*
A* SFLMSGRCD specify message show from line XX
A SFLMSGRCD(23)
A KEYVAR SFLMSGKEY
A SFPGMQ SFLPGMQ(10)
A*-------------------------------------*
A R CTLMSG SFLCTL(SFLMSG)
A*-------------------------------------*
A OVERLAY
A SFLDSP
A SFLDSPCTL
A 65 SFLEND
A SFLINZ
A SFLSIZ(0011)
A SFLPAG(0002)
A SFPGMQ SFLPGMQ
QRPGLESRC SFLMSGR
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
H DATEDIT(*YMD/)
FSFLMSGD CF E WORKSTN
F INFDS(INFDSP)
D******************************************************
D* D E F I N E D A T A - S T R U C T U R E *
D******************************************************
D INFDSP DS
D PUSHED 369 369
D* 指定 ＭＥＳＳＡＧＥ ＦＩＬＥ
D* ＭＥＳＳＡＧＥ ＦＩＬＥ 可以 CRTMSGF 自行建立
D* 以 WRKMSGF 按 F6 加入訊息
D MSGF DS
D MSGFIL 1 10 INZ('QCPFMSG')
D MSGFLB 11 20 INZ('*LIBL')
D*
D DS INZ
D MSGLEN 1 4B 0
D TOPGCT 5 8B 0
D*
D PBERR DS
D BYTPRV 1 4B 0 INZ(116)
D BYTAVA 5 8B 0 INZ(0)
D ERRID 9 15
D ERR### 16 16
D ERRDTA 17 116
D******************************************************
D* D E F I N E PROGRAM STATUS PARM *
D******************************************************
D SDS
D PGMID 1 10
D WRSTN 244 253
D USER 254 263
D******************************************************
D* D E F I N E C O N S T A N T *
D******************************************************
D F3 C CONST(X'33')
C******************************************************
C* M A I N - R O U T I N E :
C******************************************************
* 將 MSGID 改為自行加入的 MSGID
C MOVE 'CPF0001' MSGID :
C MOVEL(P) 'TEST' MSG :
C EXSR @SNDPM :
C*
C MOVE 'CPF0002' MSGID :
C EXSR @SNDPM :
C*
C MOVE 'CPF0003' MSGID :
C EXSR @SNDPM :
C*
C MOVE 'CPF0005' MSGID :
C EXSR @SNDPM :
C*
C MOVE 'CPF0006' MSGID :
C EXSR @SNDPM :
C*
C MOVE 'CPF0007' MSGID :
C EXSR @SNDPM :
C*
C MOVE 'CPF0008' MSGID :
C EXSR @SNDPM :
C*
C MOVE 'CPF0010' MSGID :
C EXSR @SNDPM :
C*
C MOVE 'CPF0011' MSGID :
C EXSR @SNDPM :
C*
C MOVE 'CPF0190' MSGID :
C EXSR @SNDPM :
C*
C MOVE 'CPF0191' MSGID :
C EXSR @SNDPM :
C*
C MOVE 'CPF0192' MSGID :
C EXSR @SNDPM :
C*
C F3 DOUEQ PUSHED :
C*
C WRITE CTLMSG :MSG SFL
C EXFMT HED01 :OPTION ENTRY
C EXSR @RMVPM :
C*
C END :
C*
C MOVE *ON *INLR :
C RETURN :
C******************************************************
C* S U B - R O U T I N E :
C******************************************************
C*----------------------------------------------------*
C *INZSR BEGSR :
C*----------------------------------------------------*
C MOVE *ON *IN65 :
C MOVEL PGMID SFPGMQ :FOR MSG SFL
C*
C ENDSR :
C*----------------------------------------------------*
C @SNDPM BEGSR :
C*----------------------------------------------------*
C CALL 'QMHSNDPM' :
C PARM MSGID 7 :
C PARM MSGF :
C PARM MSG 78 :
C PARM 78 MSGLEN :
C PARM '*INFO' MSGTYP 10 :
C PARM '*' TOPGMQ 10 :
C PARM 0 TOPGCT :
C PARM KEYVAR 4 :
C PARM PBERR :
C*
C MOVE *BLANK MSG :
C*
C ENDSR :
C*----------------------------------------------------*
C @RMVPM BEGSR :
C*----------------------------------------------------*
C CALL 'QMHRMVPM' :
C PARM '*' TOPGMQ :
C PARM 0 TOPGCT :
C PARM *BLANK KEYVAR :
C PARM '*OLD ' CLEAR 10 :
C PARM PBERR :
C*
C ENDSR
2000-07-10 如何針對畫面 Subfile data 動態排序?
□ Tips : 如何針對畫面 Subfile data 動態排序?
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Usage:
1. Create SQLSFLPF PF
2. Create SQLSFLSRTD DSPF
3. Create SQLSFLSRTR
4. Call SQLSFLSRTR, Press F4 to select key
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
QDDSSRC: SQLSFLPF Type: PF
A UNIQUE
A R SFL001
A DBLNAM 12
A DBFNAM 10
A DBMINI 1
A DBNNAM 10
A K DBLNAM
A K DBFNAM
QDDSSRC: SQLSFLSRTD Type: DSPF
A DSPSIZ(24 80 *DS3)
A PRINT ERRSFL
A CA03 CA12 CF04
A*
A R SFL1 SFL
A DBLNAM R O 5 2REFFLD(DBLNAM SQLSFLPF)
A DBFNAM R O 5 26REFFLD(DBFNAM SQLSFLPF)
A DBMINI R O 5 50REFFLD(DBMINI SQLSFLPF)
A DBNNAM R O 5 55REFFLD(DBNNAM SQLSFLPF)
A*
A R SF1CTL SFLCTL(SFL1)
A SFLSIZ(0050) SFLPAG(0017)
A OVERLAY
A N32 SFLDSP
A N31 SFLDSPCTL
A 31 SFLCLR
A 90 SFLEND(*MORE)
A RRN1 4S 0H SFLRCDNBR
A 4 2'Last Name' DSPATR(HI)
A 4 26'First Name' DSPATR(HI)
A 4 50'MI' DSPATR(HI)
A 4 55'Nick Name' DSPATR(HI)
A 1 2'PGM :SQLSFLSRTR'
A 2 2'DSPF:SQLSFLSRTD'
A 1 26'Dynamic Sort with Embedded SQL'
A DSPATR(HI)
A 1 71DATE EDTCDE(Y)
A 2 71TIME
A*
A R FKEY1
A 23 2'F3=Exit' COLOR(BLU)
A +3'F4=Prompt' COLOR(BLU)
A +3'F12=Cancel' COLOR(BLU)
A R WINDOW1
A WINDOW(*DFT 11 25)
A TAB1 1 B 3 2
A 3 5'Last Name'
A TAB2 1 B 4 2
A 4 5'First Name'
A TAB3 1 B 5 2
A 5 5'Middle Initial'
A TAB4 1 B 6 2
A 6 5'Nick Name'
A 10 1'F3=Exit' COLOR(BLU)
A 10 11'F12=Cancel' COLOR(BLU)
A 1 3'Select a sort field'
A DSPATR(HI)
QRPGLESRC: SQLSFLSRTR Type: SQLRPGLE
*****************************************************************
* To compile:
* CRTSQLRPGI OBJ(xxx/SFL013RG) SRCFILE(xxx/QRPGLESRC) +
* SRCMBR(SFL013RG) RDB(*LOCAL) OBJTYPE(*PGM) +
* DLYPRP(*YES) SQLPKG(*OBJ)
*****************************************************************
FSQLSFLSRTDcf e workstn sfile(sfl1:rrn1)
F infds(info)
*
* Information data structure to hold attention indicator byte.
Dinfo ds
D cfkey 369 369
* Constants for attention indicator byte
Dexit C const(X'33')
Dprompt C const(X'34')
Dcancel C const(X'3C')
Denter C const(X'F1')
Dorder S 8 INZ('dblnam')
Dselct1 S 500A INZ('SELECT dblnam, dbfnam, -
D dbmini, dbnnam -
D FROM sqlsflpf -
D ORDER BY ')
Dselct2 S 500A INZ(' ')
* Establish the connection to the remote machine. The -842 return
* code indicates that the connection is already established. If
* you want to connect to the local machine, use CONNECT.
C/EXEC SQL
C+ CONNECT reset
C/END-EXEC
C exsr prep
C exsr sflbld
*
C dou (cfkey = exit)
C write fkey1
C exfmt sf1ctl
C select
* prompt to selection sorting criteria
C when cfkey = prompt
C exsr sort
C exsr clean
C exsr prep
C exsr sflbld
C when cfkey = cancel
C leave
C endsl
C enddo
*
C exsr clean
* Disconnect the current connection.
C/EXEC SQL
C+ DISCONNECT CURRENT
C/END-EXEC
C eval *inlr = *on
*****************************************************************
* Prepare SQL cursor
*****************************************************************
C prep begsr
*
* Prepare the SQL statement for validation, since the program was
* compiled with DLYPRP (*YES), it will wait until it is used before
* it prepares the cursor.
*
C eval selct2 = %trimr(selct1) + ' ' + order
*
C/EXEC SQL
C+ PREPARE sel FROM :selct2
C/END-EXEC
*
* Declare the SQL cursor to hold the data retrieved from the SELECT
C/EXEC SQL
C+ DECLARE MYCSR SCROLL CURSOR FOR SEL
C/END-EXEC
*
* Open the SQL cursor.
C/EXEC SQL
C+ OPEN MYCSR
C/END-EXEC
*
C endsr
*****************************************************************
* Clean up before exiting
*****************************************************************
C clean begsr
*
* Close the SQL cursor after all processing is complete.
C/EXEC SQL
C+ CLOSE MYCSR
C/END-EXEC
*
C endsr
*****************************************************************
* Build the subfile
*****************************************************************
C sflbld begsr
*
* Clear the subfile
C eval *in31 = *on
C write sf1ctl
C eval *in31 = *off
C eval rrn1 = 0
*
* Process the records in the SQL cursor until the return not = 0
C dou sqlcod <> 0
* Get the next row from the SQL cursor.
C/EXEC SQL
C+ FETCH NEXT FROM MYCSR
C+ INTO :dblnam, :dbfnam, :dbmini, :dbnnam
C/END-EXEC
C if sqlcod = 0
C eval rrn1 = rrn1 + 1
C write sfl1
C endif
C enddo
*
C if rrn1 = 0
C eval *in32 = *on
C else
C eval rrn1 = 1
C endif
*
C eval *in90 = *on
*
C endsr
*****************************************************************
* SORT - prompt to select sort criteria
*****************************************************************
C sort begsr
*
C exfmt window1
*
C select
C when tab1 <> *blank
C movel(p) 'dblnam' order
C clear tab1
C when tab2 <> *blank
C movel(p) 'dbfnam' order
C clear tab2
C when tab3 <> *blank
C movel(p) 'dbmini' order
C clear tab3
C when tab4 <> *blank
C movel(p) 'dbnnam' order
C clear tab4
C endsl
*
C endsr
訂閱：
文章 (Atom)