Hi All,
i want one program of single page subfile(RPG Code Example)..
Non-Sql
i want one program of single page subfile(RPG Code Example)..
Non-Sql
A*%%TS SD 20060825 153501 REL-V5R3M0 5722-WDS
A*%%EC
A DSPSIZ(24 80 *DS3)
A REF(*LIBL/LBAFREF)
A PRINT
A INDARA
A CF01
A CF02
A CF03
A CF04
A CF05
A CF06
A CF07
A CF08
A CF09
A CF10
A CF11
A CF12
A CF13
A CF14
A CF15
A CF16
A CF17
A CF18
A CF19
A CF20
A CF21
A CF22
A CF23
A CF24
A ROLLUP
A ROLLDOWN
A**************************************************************************
A R SUB01 SFL
A*%%TS SD 20060811 130230 REL-V5R3M0 5722-WDS
A S1OPT 1A B 8 4
A S1NAME 10 O 8 7
A S1TYPE 6 O 8 18
A S1CRTDT 6Y 0O 8 56EDTWRD(' / / ')
A S1CHGDT 6Y 0O 8 65EDTWRD(' / / ')
A S1DESC 30 O 8 25
A**************************************************************************
A R SUB01CTL SFLCTL(SUB01)
A*%%TS SD 20060825 153501 REL-V5R3M0 5722-WDS
A SFLSIZ(0014)
A SFLPAG(0010)
A RTNCSRLOC(&#REC &#FLD)
A OVERLAY
A SFLCSRRRN(&WHERE)
*
A CSRLOC(ROW COL)
*
A 31 SFLDSP
A 32 SFLDSPCTL
A 30 SFLCLR
A 33 SFLEND(*MORE)
A SCRRN 4S 0H SFLRCDNBR
A 1 2DATE
A EDTCDE(Y)
A 1 12TIME
A HDCOMPANY 30A O 1 26DSPATR(HI)
A C1TITLE 40A O 2 21DSPATR(HI)
A 4 4'Type options, press Enter'
A COLOR(BLU)
A HDPROGRAM 10A O 1 71
A #REC 10A H
A #FLD 10A H
A WHERE 5S 0H
A ROW 3S 0H
A COL 3S 0H
A 7 3'Opt'
A DSPATR(HI)
A 7 7'Name '
A DSPATR(HI)
A DSPATR(UL)
A 7 18'Type '
A DSPATR(HI)
A DSPATR(UL)
A 7 25'Description '
A DSPATR(HI)
A DSPATR(UL)
A 7 56'Create '
A DSPATR(UL)
A DSPATR(HI)
A 7 65'Change '
A DSPATR(HI)
A DSPATR(UL)
A S1FIELD1 3 B 5 7
A S1FIELD2 3 B 5 13
A**************************************************************************
A R FKEY01
A*%%TS SD 20051021 132023 REL-V5R3M0 5722-WDS
A 23 2'F3=Exit'
A COLOR(BLU)
*=========================================================================
* Message subfile stuff.
*=========================================================================
A R MSGSFL SFL
A SFLMSGRCD(24)
A MSGKEY SFLMSGKEY
A PGMQ SFLPGMQ(10)
A*=========================================================================
A* Message subfile stuff
A*=========================================================================
A R MSGCTL SFLCTL(MSGSFL)
A*%%TS SD 20050412 101817 REL-V5R3M0 5722-WDS
A OVERLAY
A SFLDSP
A SFLDSPCTL
A SFLINZ
A N03 SFLEND
A SFLSIZ(0002)
A SFLPAG(0001)
A PGMQ SFLPGMQ(10)
*=====================================================
* PROGRAM - RPG
* PURPOSE - List members in source file QRPGLESRC
*
* PROGRAM DESCRIPTION
* This program will list members in a source file
* to a subfile.
*
*
* INPUT PARAMETERS
* Description Type Size How Used
* ----------- ---- ---- --------
*
* INDICATOR USAGE
* n/a
*
*=====================================================
fRPGD cf e workstn INFDS(INFDS)
f SFILE(SUB01:RRN1)
// Data Structures
d Infds ds
d Choice 369 369
d rowcol 370 371I 0
d Currec 378 379I 0
// Command Keys
d Cmd01 c const(x'31') Cmd-1
d Cmd02 c const(x'32') Cmd-2
d LeaveProgram c const(x'33') Cmd-3
d Cmd04 c const(x'34') Cmd-4
d Cmd05 c const(x'35') Cmd-5
d Cmd06 c const(x'36') Cmd-6
d Cmd07 c const(x'37') Cmd-7
d Cmd08 c const(x'38') Cmd-8
d Cmd09 c const(x'39') Cmd-9
d Cmd10 c const(x'3A') Cmd-10
d Cmd11 c const(x'3B') Cmd-11
d Cmd12 c const(x'3C') Cmd-12
d Cmd13 c const(x'B1') Cmd-13
d Cmd14 c const(x'B2') Cmd-14
d Cmd15 c const(x'B3') Cmd-15
d Cmd16 c const(x'B4') Cmd-16
d Cmd17 c const(x'B5') Cmd-17
d Cmd18 c const(x'B6') Cmd-18
d Cmd19 c const(x'B7') Cmd-19
d Cmd20 c const(x'B8') Cmd-20
d Cmd21 c const(x'B9') Cmd-21
d Cmd22 c const(x'BA') Cmd-22
d Cmd23 c const(x'BB') Cmd-23
d Cmd24 c const(x'BC') Cmd-24
d EnterKey c const(x'F1')
d RollUp c const(x'F5') Roll Up
d RollDown c const(x'F4') Roll Down
*
* Program Info
*
d SDS
d @PGM 001 010
d @PARMS 037 039 0
d @MSGDTA 91 170
d @MSGID 171 174
d @JOB 244 253
d @USER 254 263
d @JOB# 264 269 0
// constants
//
*
* Field Definitions.
*
d @Scrn1 s 1 inz('Y')
d AllMembers s 10a inz('*ALL')
d ApiFile s 10 inz('QRPGLESRC')
d ApiLibrary s 10 inz('*LIBL')
d ApiMember s 10
d bOvr s 1a inz('0')
d cmdstring s 256
d cmdlength s 15 5
d count s 4 0
d Digits c const('01235456789')
d FileLib s 20a
d Format s 8a
d hrow s 3 0
d hcol s 3 0
d IsoDate s D
d LenStr s 4 0
d MemberName s 10
d messagecsc s 10i 0
d messagedata s 80A
d messagekey s 4A
d messagelen s 10i 0 inz(256)
d messagefile s 20 inz('QCPFMSG *LIBL')
d messageid s 7
d myspace s 20 inz('SUBEXAMPLEQTEMP ')
*
d nBufLen s 10i 0
d ObjectLib s 10
d ReceiverLen s 9b 0 inz(100)
d Reloadsub01 s 1
d RRN1 s like(SCRRN)
d SavRrn s like(SCRRN)
d Screenerror s 1 inz('N')
d size s 10I 0 inz(250000)
d sizelist s 10i 0
d SpaceVal s 1 inz(*BLANKS)
d SpaceAuth s 10 inz('*CHANGE')
d SpaceText s 50 inz(*BLANKS)
d SpaceRepl s 10 inz('*YES')
d SpaceAttr s 10 inz(*BLANKS)
d Title s 40
d Title30 s 30
d WorkDate8 s 8 0
*
* QUSRMBRD API return Struture
* ============================
d Mbrd0100 ds inz
d nBytesRtn 10i 0
d nBytesAval 10i 0
d DBXLIB 10a
d DBXFIL 10a
d MbrName 10a
d FileAttr 10a
d SrcType 10a
d dtCrtDate 13a
d dtLstChg 13a
d MbrText 50a
d bIsSource 1a
d RmtFile 1a
d LglPhyFile 1a
d ODPSharing 1a
d filler2 2a
d RecCount 10i 0
d DltRecCnt 10i 0
d DataSpaceSz 10i 0
d AccpthSz 10i 0
d NbrBasedOnMbr 10i 0
*
* Create userspace datastructure
*
d DS
d StartPosit 1 4i 0
d StartLen 5 8i 0
d SpaceLen 9 12i 0
d ReceiveLen 13 16i 0
d MessageKeyE 17 20i 0
d MsgDtaLen 21 24i 0
d MsgQueNbr 25 28i 0
*
* Date structure for retriving userspace info
*
d InputDs DS
d UserSpace 1 20
d SpaceName 1 10
d SpaceLib 11 20
d InpFileLib 29 48
d InpFFilNam 29 38
d InpFFilLib 39 48
d InpRcdFmt 49 58
*
* Data structure for the retrieve user space command
*
d GENDS DS
d OffsetHdr 117 120i 0
d SizeHeader 121 124i 0
d OffsetList 125 128i 0
d NbrInList 133 136i 0
d SizeEntry 137 140i 0
*
* Datastructure for retrieving elements from userspace
*
d HeaderDs DS
d OutFileNam 1 10
d OutLibName 11 20
d OutType 21 25
d OutFormat 31 40
d RecordLen 41 44B 0
*
* List the members
*
d ListDs DS
d LmMember 10
d LmType 10
d LmCreationDt 7
d LmCreationTm 6
d LmLastChgDt 7
d LmLastChgTm 6
d LmDescription 50
*
* API Error Data Structure
*
d APIError ds Qualified
d BytesP 1 4I 0 inz(%size(apiError))
d BytesA 5 8I 0 inz(0)
d Messageid 9 15
d Reserved 16 16
d messagedta 17 256
*
* formational data structure Message subfile
*
d DS INZ
d STKCNT 10i 0
d DTALEN 10i 0
d ERRCOD 10i 0
//
// external calls
//
d $command pr extpgm('QCMDEXC')
d command 5000 options(*varsize)
d Length 15 5
d $sendmsg PR ExtPgm('QMHSNDPM')
d MessageID 7A Const
d QualMsgF 20A Const
d MsgData 256A Const
d MsgDtaLen 10I 0 Const
d MsgType 10A Const
d CallStkEnt 10A Const
d CallStkCnt 10I 0 Const
d Messagekey 4A
d ErrorCode 256A
d $clearmsg pr extpgm('QMHRMVPM')
d messageq 276a const
d CallStack 10i 0 const
d Messagekey 4a const
d messagermv 10a const
d ErrorCode 256
d $CreateSpace PR extpgm('QUSCRTUS')
d UsrSpc 20A const
d ExtAttr 10A const
d InitialSize 10I 0 const
d InitialVal 1A const
d PublicAuth 10A const
d Text 50A const
d Replace 10A const
d ErrorCode 256A
d $ListMembers PR extpgm('QUSLMBR')
d myspace 20A const
d Format 10A const
d FileLib 20 const
d AllMembers 10A const
d bOvr 1A const
d ErrorCode 256A
d $ReadSpace PR extpgm('QUSRTVUS')
d myspace 20A const
d StartPosit 10I 0 const
d StartLen 10I 0 const
d GENDS 1A const
d ErrorCode 256A
/Free
//--------------------------------------------------------
// MAIN PROGRAM
//--------------------------------------------------------
// send message that report was printed.
messageid = 'CPF9898';
messagedata = 'Enter Data, Press ' +
'<ENTER> to continue';
exsr $SNDMSG;
screenerror = 'Y';
exsr $ListAllMembers;
exsr $ClearSFL;
exsr $LoadSFL;
dow @Scrn1 = 'Y';
if screenerror = 'N';
exsr $CLRMSG;
endif;
write fkey01;
write(e) msgctl;
exfmt sub01ctl;
row = %div(ROWCOL:256);
col = %rem(ROWCOL:256);
exsr $CLRMSG;
select;
when Choice = LeaveProgram;
clear @Scrn1;
other;
reset screenerror;
endsl;
enddo;
*inlr = *on;
//--------------------------------------------------------
// $ListAllMembers - list members to userspace
//--------------------------------------------------------
begsr $ListAllMembers;
FileLib = ApiFile + ApiLibrary;
//
// Now List the members of this source file to a userspace
//
// Create a user space
$createSpace(MYSPACE: 'USRSPC': size: x'00': '*ALL':
'Temp User Space for Example': '*YES': ApiError);
MemberName = '*ALL';
Format = 'MBRL0200';
nBufLen = %size(MbrD0100);
$ListMembers(myspace :Format:Filelib:AllMembers:
bOvr:ApiError);
//
// Read back the members
//
StartPosit = 1;
StartLen = 140;
//
// First call to get data offsets(start)
//
$readSpace(myspace :StartPosit:StartLen:GENDS:APIError);
//
// Then call to get number of entries
//
StartPosit = OffsetHdr + 1;
StartLen = SizeHeader;
$readSpace(myspace :StartPosit:StartLen:HeaderDS:APIError);
StartPosit = OffsetList + 1;
StartLen = SizeEntry;
endsr;
//--------------------------------------------------------
// $ClearSFL - Clear the subfile
//--------------------------------------------------------
begsr $CLEARSFL;
*in31 = *Off;
*in32 = *Off;
*in30 = *On;
write SUB01CTL;
*in31 = *On;
*in32 = *On;
*in30 = *Off;
clear RRN1;
clear SCRRN;
clear SavRrn;
clear S1OPT;
endsr;
//--------------------------------------------------------
// $LoadSfl - Load up the route errors
//--------------------------------------------------------
begsr $LoadSFL;
if SavRrn > *zeros;
RRN1 = SavRRN;
SCRRN = SavRRN;
endif;
//
// Do for number of members
//
for count = 1 to NbrInList;
$readSpace(myspace :StartPosit:StartLen:ListDS:APIError);
s1name = lmmember;
s1type = lmtype;
s1desc = LmDescription;
RRN1 +=1;
SCRRN = RRN1;
write SUB01;
StartPosit = StartPosit + SizeEntry;
endfor;
*in33 = *On;
SavRrn = SCRRN;
//
// If no records in subfile then do not disply the subfile.
//
if SavRrn = *zeros and *in33;
*in31 = *off;
else;
RRN1 = 1.;
SCRRN = 1.;
endif;
endsr;
//--------------------------------------------------------
// $sndmsg - send subfile message
//--------------------------------------------------------
begsr $sndmsg;
$sendmsg(messageID :
messageFile :
messagedata :
messageLen :
'*DIAG' :
@PGM :
messagecsc :
messagekey :
APIError
);
endsr;
//--------------------------------------------------------
// $clrmsg - clear all subfile message(s)
//--------------------------------------------------------
begsr $clrmsg;
$clearmsg('*' :
*zero :
*blanks :
'*ALL' :
APIError
);
endsr;
//--------------------------------------------------------
// *inzsr - one time run subroutine
//--------------------------------------------------------
begsr *inzsr;
PGMQ = @PGM;
DTALEN = 60;
Title = 'Subfile Shell Program';
LenStr = ((%len(Title) -
%len(%trim(Title))) / 2) + 1;
%subst(C1TITLE:LenStr) = %trim(Title);
Title30 = 'Test Company';
LenStr = ((%len(Title30) -
%len(%trim(Title30))) / 2) + 1;
%subst(HDCOMPANY:LenStr) = %trim(Title30);
endsr;
/End-Free
Comment