如何動態選取要儲存的物件或原始檔成員(TFROBJ) ?
有時候由於檔案或原始檔某些成員需要傳至另一個 AS/400(iSeries) 系統，
所以需要使用 SAVOBJ 的方式儲存，但是又須麻煩的一個一個輸入指定物件或原
始檔成員，所以我寫一個程式針對同一個 Library 中的物件或原始檔中
成員讓使用者選取，並將所選儲存至同一 Library SAVF 中，然後你可以
使用此 SAVF 利用 FTP 或 SNDNETF 或 SAVRSTOBJ 傳輸至另一系統中。
此程式中使用 Source-Library -> 欲儲存的 Library
Targrt-Library -> 欲 Restored 到目的地 Library，目前未使用，若需要將傳輸及自動 Restored 時，你可以利用此參數。
二個參數，並將選取的物件存至 Source-Library 中以同 Source-Library 為名的 SAVF。
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
由於此程式利用 QTEMP 暫存檔處理，所以安裝程序須照下列方式，否則無法編譯完成：
1. 將 TFROBJC 程式後段修改如下：
/* SELECT OBJECT TO SAVED */
/* CALL TFROBJR */
/* CONSTRUCT SAVRST COMMAND */
/* RTVMBRD FILE(QTEMP/SAVMBRLIST) NBRCURRCD(&CURRCD) */
/* IF (&CURRCD > 0) + */
/* CALL TFROBJC1 (&SRCLIB &TOLIB) */
儲存，執行編譯 CRTCLPGM TFROBJC完成後，
執行 CALL TFROBJC ('QGPL' 'QGPL' '*ALL')產生暫存檔 QTEMP/SAVMBRLIST 供 TFROBJR 使用。
2. CRTDSPF TFROBJD
3. CRTBNDRPG TFROBJR
4. CRTCLPGM TFROBJC1
5. 回復 TFROBJC 後段為：
/* SELECT OBJECT TO SAVED */
CALL TFROBJR
/* CONSTRUCT SAVRST COMMAND */
RTVMBRD FILE(QTEMP/SAVMBRLIST) NBRCURRCD(&CURRCD)
IF (&CURRCD > 0) +
CALL TFROBJC1 (&SRCLIB &TOLIB)
儲存，執行編譯 CRTCLPGM TFROBJC 完成安裝。
執行程式語法：
CALL TFROBJC ('source-library' 'target-library')
星期一, 11月 06, 2023
2003-06-10 如何動態選取要儲存的物件或原始檔成員(TFROBJ) ?
訂閱：
張貼留言 (Atom)
沒有留言:
張貼留言