Article

Dynamical selected objects -- code

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  > 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


There are Comments. Add yours.

 
TIP: Want to include a code block in your comment? Use <pre> or <code> tags around the desired text. Ex: <code>insert code</code>

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy
Sort by: OldestNewest

Forgot Password?

No problem! Submit your e-mail address below. We'll send you an email containing your password.

Your password has been sent to: