Main program TFROBJC needs 2 parameters:
One is Source-Library
The other is Target-Library(Currently not used in the program), the target is for linking to FTP, SAVRSTOBJ used. You can modify the source to achieve your request.
The utility have following:
TFROBJC -- main program
TFROBJC1 -- create SAVOBJ command
TFROBJD -- object/member selection screen
TFROBJR -- object/member selection processing pgm
The utility will create a SAVF name same as source-library name stored in source library.
Installation step:
1.
mark TFROBJC last section following lines:
/* SELECT OBJECT TO SAVED */
CALL TFROBJR
/* CONSTRUCT SAVRST COMMAND */
RTVMBRD FILE(QTEMP/SAVMBRLIST) NBRCURRCD(&CURRCD)
IF (&CURRCD > 0) +
CALL TFROBJC1 (&SRCLIB &TOLIB)
saved source and compiled it.
Run TFROBJC to create QTEMP/SAVMBRLIST for TFROBJR compiled used.
2. CRTDSPF TFROBJD
3. CRTBNDRPG TFROBJR
4. CRTCLPGM TFROBJC1
5. Unmarked TFROBJC lines marked at step 1. Recreate TFROBJC.
Utility usage:
CALL TFROBJC ('source-library' 'target-library')
or
CALL TFROBJC ('QGPL' 'QGPL')
File : QCLSRC
Member: TFROBJC
Type : CLP
Usage : CRTCLPGM TFROBJC
PGM (&SRCLIB &TOLIB)
DCL VAR(&SRCLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&TOLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&SAVOBJTYP) TYPE(*CHAR) LEN(10)
DCL VAR(&CURRCD) TYPE(*DEC) LEN(10 0)
DCLF QAFDBASI
/* OUTPUT OBJ DESCRIPTION TO OUTFILE */
DSPOBJD OBJ(&SRCLIB/*ALL) OBJTYPE(*ALL) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPOBJ)
/* OUTPUT FILE DESCRIPTION TO OUTFILE */
DSPFD FILE(&SRCLIB/*ALL) TYPE(*BASATR) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPFD)
OVRDBF FILE(QAFDBASI) TOFILE(QTEMP/DSPFD)
DLTF DSPMBRLIST
MONMSG CPF0000
NEXT:
RCVF
MONMSG CPF0864 EXEC(GOTO MBRLISTEND)
IF (&ATDTAT = 'S') +
DSPFD FILE(&ATLIB/&ATFILE) TYPE(*MBRLIST) +
OUTPUT(*OUTFILE) +
OUTFILE(QTEMP/DSPMBRLIST) OUTMBR(*FIRST *ADD)
GOTO NEXT
MBRLISTEND:
DLTF QTEMP/SAVMBRLIST
MONMSG CPF0000
/* CREATE TEMP FILE TO SAVE SAVED MEMBER NAME AND OBJ */
CRTDUPOBJ OBJ(QAFDMBRL) FROMLIB(*LIBL) OBJTYPE(*FILE) +
TOLIB(QTEMP) NEWOBJ(SAVMBRLIST)
ADDPFM FILE(QTEMP/SAVMBRLIST) MBR(SAVMBRLIST)
/* SELECT OBJECT TO SAVED */
CALL TFROBJR
/* CONSTRUCT SAVRST COMMAND */
RTVMBRD FILE(QTEMP/SAVMBRLIST) NBRCURRCD(&CURRCD)
IF (&CURRCD >
Requires Free Membership to View
Register today to access targeted resources from our editorial writers and independent industry experts including news, tips, and advice to help you do your job more efficiently and effectively. Stay informed on the hottest topics and biggest challenges faced by IT professionals working with iSeries products and services.
0) +
CALL TFROBJC1 (&SRCLIB &TOLIB)
ENDPGM
File : QCLSRC
Member: TFROBJC1
Type : CLP
Usage : CRTCLPGM TFROBJC1
PGM (&SRCLIB &TOLIB)
DCL VAR(&SRCLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&TOLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&SAVOBJTYP) TYPE(*CHAR) LEN(10)
DCL VAR(&CMDSTR) TYPE(*CHAR) LEN(3000) +
VALUE('SAVOBJ OBJ(')
DCL VAR(&MLFILES) TYPE(*CHAR) LEN(10) +
VALUE(' ')
DCL VAR(&SAVFILE) TYPE(*CHAR) LEN(10)
DCL VAR(&SAVOBJS) TYPE(*CHAR) LEN(7) +
VALUE('SAVOBJ ')
DCL VAR(&OBJS) TYPE(*CHAR) LEN(4) VALUE('OBJ(')
DCL VAR(&OBJSS) TYPE(*CHAR) LEN(150)
DCL VAR(&LIBS) TYPE(*CHAR) LEN(4) VALUE('LIB(')
DCL VAR(&DEVS) TYPE(*CHAR) LEN(11) +
VALUE('DEV(*SAVF) ')
DCL VAR(&OBJTYPS) TYPE(*CHAR) LEN(14) +
VALUE('OBJTYPE(*ALL) ')
DCL VAR(&SAVFS) TYPE(*CHAR) LEN(15) VALUE('SAVF(')
DCL VAR(&FILEMBRS) TYPE(*CHAR) LEN(15) +
VALUE('FILEMBR(')
DCL VAR(&LEFT) TYPE(*CHAR) LEN(1) VALUE('(')
DCL VAR(&RIGHT) TYPE(*CHAR) LEN(2) VALUE(') ')
DCL VAR(&SLASH) TYPE(*CHAR) LEN(1) VALUE('/')
DCL VAR(&MBRS) TYPE(*CHAR) LEN(300)
DCL VAR(&WITHMBRS) TYPE(*CHAR) LEN(1)
DCLF QAFDMBRL
CHGVAR &SAVFILE &SRCLIB
DLTF &SRCLIB/&SAVFILE
MONMSG CPF0000
CRTSAVF FILE(&SRCLIB/&SAVFILE)
OVRDBF FILE(QAFDMBRL) TOFILE(QTEMP/SAVMBRLIST)
NEXT:
RCVF
MONMSG CPF0864 EXEC(GOTO MBRLISTEND)
IF (&MLFILES *NE &MLFILE) DO
/* SAVOBJ +
OBJ(FILE) LIB(SRCLIB) DEV(*SAVF) +
OBJTYPE(*FILE) SAVF(SRCLIB/SAVF) +
FILEMBR((FILE1 (MBR1 MBR2)) (FILE2 (MBR1 +
MBR2))) */
IF (&MLFILES *NE ' ' *AND +
&MLNAME *NE ' ') DO
CHGVAR &MBRS +
(&MBRS *TCAT &RIGHT *TCAT &RIGHT)
ENDDO
CHGVAR &MLFILES &MLFILE
CHGVAR &OBJSS (&OBJSS *BCAT &MLFILE)
IF (&MLNAME *NE ' ') DO
CHGVAR &MBRS +
(&MBRS *BCAT &LEFT *CAT &MLFILE *BCAT &LEFT)
CHGVAR &WITHMBRS '1'
ENDDO
ENDDO
IF (&MLNAME *NE ' ') +
CHGVAR &MBRS +
(&MBRS *BCAT &MLNAME)
GOTO NEXT
MBRLISTEND:
DLTOVR FILE(*ALL)
CHGVAR &CMDSTR +
(&SAVOBJS *CAT +
&OBJS *TCAT &OBJSS *TCAT &RIGHT *CAT +
&LIBS *TCAT &MLLIB *TCAT &RIGHT *CAT +
&DEVS *CAT +
&OBJTYPS *CAT +
&SAVFS *TCAT &SRCLIB *TCAT &SLASH *CAT +
&SAVFILE *TCAT &RIGHT)
CHGVAR &MBRS +
(&MBRS *TCAT &RIGHT *TCAT &RIGHT *TCAT &RIGHT)
IF (&WITHMBRS = '1') DO
CHGVAR &CMDSTR +
(&CMDSTR *BCAT &FILEMBRS *CAT &MBRS)
ENDDO
CALL QCMDEXC (&CMDSTR 3000)
SNDPGMMSG MSG('SAVF' *BCAT &SAVFILE *BCAT 'created in' +
*BCAT &SRCLIB *TCAT '.') TOPGMQ(*PRV +
(TFROBJC))
ENDPGM
File : QDDSSRC
Member: TFROBJD
Type : DSPF
Usage : CRTDSPF TFROBJD
*===============================================================
*
* To compile:
*
* CRTDSPF FILE(XXX/TFROBJD) SRCFILE(XXX/QDDSSRC)
*
*===============================================================
A*
A*%%EC
A DSPSIZ(24 80 *DS3)
A PRINT
A ERRSFL
A CA03
A CA12
A*
A R SFL1 SFL
A*
A SELECT 1 B 6 2
A MLFILE 10 O 6 4
A MLNAME 10 O 6 15
A MLCDAT 6 O 6 26
A MLCHGD 6 O 6 33
A ODOBNM 10 O 6 40
A ODOBTP 8 O 6 51
A ODOBOW 10 O 6 60
A ODLDAT 6 O 6 71
A ODCDAT 6 H
A*
A*
A R SF1CTL SFLCTL(SFL1)
A SFLSIZ(0017)
A SFLPAG(0016)
A OVERLAY
A N32 SFLDSP
A N31 SFLDSPCTL
A 31 SFLCLR
A 90 SFLEND(*MORE)
A SFLCSRRRN(&CSRRRN1)
A RRN1 4S 0H SFLRCDNBR
A CSRRRN1 5S 0H
A 1 2'TFROBJR '
A 1 28'____________Your _Company name'
A COLOR(WHT)
A 1 71DATE
A EDTCDE(Y)
A 2 29'____________Select Object or SRC Member to save'
A COLOR(WHT)
A 2 71TIME
A 3 1'___X__'
A 4 3'LIBRARY:'
A SAVLIB 10 O 4 12
A 5 4'FILE'
A COLOR(WHT)
A 5 15'MEMBER'
A COLOR(WHT)
A 4 26'CRT'
A COLOR(WHT)
A 5 26'DATE'
A COLOR(WHT)
A 3 33'LAST'
A COLOR(WHT)
A 4 33'CHANGE'
A COLOR(WHT)
A 5 33'DATE'
A COLOR(WHT)
A 5 40'OBJECT'
A COLOR(WHT)
A 5 51'TYPE'
A COLOR(WHT)
A 5 60'OWNER'
A COLOR(WHT)
A 3 71'LAST'
A COLOR(WHT)
A 4 71'CHANGED'
A COLOR(WHT)
A 5 71'DATE'
A COLOR(WHT)
A*
A R SFL2 SFL
A*
A SELECT 1 B 6 2
A ODLBNM 10 O 6 4
A ODOBNM 10 O 6 15
A ODOBTP 8 O 6 26
A ODOBAT 10 O 6 37
A ODCDAT 6 O 6 48
A ODLDAT 6 O 6 55
A ODOBOW 10 O 6 62
A R SF2CTL SFLCTL(SFL2)
A SFLSIZ(0017)
A SFLPAG(0016)
A OVERLAY
A N32 SFLDSP
A N31 SFLDSPCTL
A 31 SFLCLR
A 90 SFLEND(*MORE)
A RRN2 4S 0H
A 1 2'TFROBJR '
A 1 28'_Your Company name____________'
A COLOR(WHT)
A 1 71DATE
A EDTCDE(Y)
A 2 34''
A COLOR(WHT)
A 2 71TIME
A 3 1'___X__'
A 5 4'LIBRARY'
A COLOR(WHT)
A 5 15'OBJECT '
A COLOR(WHT)
A 5 26'OBJTYPE'
A COLOR(WHT)
A 5 37'ATTR'
A COLOR(WHT)
A 4 48'CRT'
A COLOR(WHT)
A 5 48'DATE'
A COLOR(WHT)
A 4 48'CHG'
A COLOR(WHT)
A 5 55'DATE'
A COLOR(WHT)
A 5 62'OWNER'
A COLOR(WHT)
A R SFL3 SFL
A SAVOBJ 10 O 6 4
A SAVMBR 10 O 6 15
A MLCDAT 6 O 6 27
A MLCHGD 6 O 6 34
A ODOBOW 10 O 6 41
*
A R SF3CTL SFLCTL(SFL3)
A SFLSIZ(0017)
A SFLPAG(0016)
A OVERLAY
A N32 SFLDSP
A N31 SFLDSPCTL
A 31 SFLCLR
A 90 SFLEND(*MORE)
A RRN3 4S 0H
A 1 2'TFROBJR '
A 1 28'Your Company Name_____________'
A COLOR(WHT)
A 1 71DATE
A EDTCDE(Y)
A 2 34'_______Confirm Selection'
A 2 71TIME
A 3 1'_______Please press Enter to confirm'
A 4 3'LIBRARY:'
A SAVLIB 10 O 4 12
A 5 4'OBJECT MEMBER'
A COLOR(WHT)
A 4 27'CRT'
A COLOR(WHT)
A 5 27'DATE'
A COLOR(WHT)
A 3 34'LAST'
A COLOR(WHT)
A 4 34'CHG'
A COLOR(WHT)
A 5 34'DATE'
A COLOR(WHT)
A 5 41'OWNER'
A COLOR(WHT)
A R FKEY1
A*
A 23 2'F3=Exit'
A COLOR(BLU)
A 23 12'F12=Cancel'
A COLOR(BLU)
File : QRPGLESRC
Member: TFROBJR
Type : RPGLE
Usage : CRTBNDRPG TFROBJR
*===============================================================
*
* To compile:
*
* CRTBNDRPG PGM(XXX/TFROBJR) SRCFILE(XXX/QRPGLESRC)
*
*===============================================================
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
H DftActGrp(*NO) ActGrp(*CALLER)
FTFROBJD cf e workstn
F sfile(sfl1:rrn1)
F sfile(sfl2:rrn2)
F sfile(sfl3:rrn3)
F infds(info)
FDSPOBJ if e disk
FDSPMBRLISTif e disk
FSAVMBRLISTO e disk rename(QWHFDML : SAVMBRR)
* Information data structure to hold attention indicator (AID) byte.
* AID byte contains a code identifying the function
* key used to return control to the program from the display file.
* For more information see the DATA MANAGEMENT GUIDE.
Dinfo ds
D cfkey 369 369
* Constants to compare to AID - F3, F12, F6, and ENTER keys.
* Other values documented in DATA MANAGEMENT GUIDE.
Dexit C const(X'33')
Dcancel C const(X'3C')
Dadd C const(X'36')
Denter C const(X'F1')
* Input parameter: Source Type or not
D savrrn S 5S 0
D confirm S 1
* Clear the subfile, then call the recursive NextLevel procedure
C ExSr clrsfl
C Exsr loadsfl
C Eval *In90 = *on
C If rrn1 = 0
C Eval *in32 = *on
C EndIf
C* Eval csrrrn1 = 1
* Simply redisplay subfile until user hits Exit or Cancel
C DoU (cfkey = exit) or (cfkey = cancel)
C Write fkey1
C ExFmt sf1ctl
C Exsr prcsfl
C If confirm = '1'
C leave
C EndIf
C EndDo
* Close files and terminate.
C Eval *inlr = *on
*********************************************************************
C ClrSfl BegSr
* Clear the subfile by activating SFLCLR and writing the subfile control
* format. Reset the subfile relative record number.
C Eval *in31 = *on
C Eval rrn1 = 0
C Write sf1ctl
C Eval *in31 = *off
*
C EndSr
*********************************************************************
C Loadsfl Begsr
* Loop until EOF is encountered.
* read DSPMBRLIST
C Read DSPMBRLIST
C DoW not %eof
C Eval select = ' '
* Update the global RRN counter, and write the new subfile record.
C Eval rrn1 = rrn1 + 1
C Write sfl1
C Read DSPMBRLIST
C EndDo
C Eval SAVLIB = MLLIB
* read DSPOBJ
C Reset SFL1
C Read DSPOBJ
C DoW not %eof
C Eval select = ' '
* Update the global RRN counter, and write the new subfile record.
C Eval rrn1 = rrn1 + 1
C Write sfl1
C Read DSPOBJ
C EndDo
C Eval savrrn = rrn1
C Eval rrn1 = 1
C EndSr
*********************************************************************
C PrcSfl Begsr
* clear sfl3
C Eval *in31 = *on
C Eval rrn3 = 0
c Write sf3ctl
C Eval *in31 = *off
C z-add 1 idx 5 0
C Eval confirm = '0'
C DoW idx < savrrn
C idx Chain sfl1
C If select = 'X'
C If MLFILE <> *blanks
C Eval SavLIB = SAVLIB
C Eval SavOBJ = MLFILE
C Eval SavMBR = MLNAME
C Else
C Eval SavLIB = SAVLIB
C Eval SavOBJ = ODOBNM
C Eval SavMBR = *BLANKS
C Eval MLCDAT = ODCDAT
C Eval MLCHGD = ODLDAT
C EndIf
C Z-add idx strrrn 4 0
C Eval rrn3 = rrn3 + 1
C Write sfl3
C Eval select = ' '
C update sfl1
C EndIf
C Eval idx = idx + 1
C EndDo
C
C If rrn3 > 0
C z-add rrn3 savrrn3 4 0
C Write fkey1
C ExFmt sf3ctl
C If (cfkey <> exit) and (cfkey <> cancel)
C Eval confirm = '1'
C Eval idx = 1
C Reset SAVMBRR
C DoW idx <= savrrn3
C idx Chain sfl3
C Eval MLLIB = SAVLIB
C Eval MLFILE= SAVOBJ
C EVAL MLNAME= SAVMBR
C EVAL MLSEU2= ODOBOW
C Write SAVMBRR
C Eval idx = idx + 1
C EndDo
C EndIf
C EndIf
C If strrrn > 0
C Z-add strrrn rrn1
C Else
C Z-add csrrrn1 rrn1
C EndIf
C EndSr