Tweet
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
-
-
Re: Single Page in Subfile
Okay it really doesnt work that way....cause I WANT to be pretty and every day I wake up Im NOT! ......You have to attempt to write a program...post what you have and we will help you correct the errors.
Here is one example on the page
please start with thatAll my answers were extracted from the "Big Dummy's Guide to the As400"
and I take no responsibility for any of them.
www.code400.com -
Re: Single Page in Subfile
jamief youll always be purty to me!
here is a free example
DDS
RPGLEPHP Code: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)
PHP Code:*=====================================================
* 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
I'm here to chew bubble gum and kick @#%@#%@#%.....and I'm all outta bubble gum !
Yes I'm talking to you squirrel nuts.Comment
Comment