Return to the RPG Tips
Generating PC file formats from AS/400 data
Ok here it is. Convert the below to Courier font and just put it in a source file(two of them) and take an Action Option 15 in PDM to create module then use CRTPGM to
create the program from the module.
You don't even have to under stand it. It works for you. Just change FILEX to your file XXXSRCNO & XXXDESC to your field names in the file. Change the HEADING subroutine to put
out the Column Headings in the file.
Put your target name in instead of the contents of FileName .
If you have any questions running it let me know. I just ran it just now so I know it works. Bring up Excel, click OPEN, click on Network Neighborhood, You
should see your AS/400 name. If you don't You should. Talk to your network people and ask why you don't see the AS/400's IFS there.
You can make this alot better, as I said in a previous post. Chain to multiple files, write out a composite record of different stuff.
Thought you folks would like it.
If you want to see more. come to COMMON and catch my sessions.
Or sign up for one of my classes from 400school.com
Respectfully
John Carr
D*=================================================================
D* Write out a .CSV file
D*=================================================================
FFILEX IF E DISK
D*=================================================================
D* @IFS - Prototypes for API's
D*=================================================================
D/COPY srclib/srcfile,@IFS
D*-----------------------------------------------------------------
D* Replace the contents of FileName with your IFS file name to be created.
D*-----------------------------------------------------------------
D Comma C CONST(',')
D Quote C CONST('"')
D Null C CONST(x'00')
D FileName S 80 INZ('/thtc/GL.csv')
D ERR_FLAG S 10I 0
D oflag S 10I 0
D rc S 10I 0
D CodePage S 10U 0 INZ(819)
D omode S 10U 0
D BufLen S 10U 0
D OutRec S 256
D str S 3 0
D EOLA S 2 INZ(x'0d25')
D NUM S 20 VARYING
C**========================================================
C** T O P O F T H E C A L C S
C**========================================================
C EXSR CRT_FILE
C EXSR OPN_FILE
C EXSR HEADING
C DOU %EOF(FILEX)
C READ FILEX
C IF %EOF(FILEX)
C LEAVE
C ENDIF
C EXSR BLDREC
C EXSR WRT_IFS
C ENDDO
C EVAL RC = close(ERR_FLAG)
C EXSR EXIT
C*
C**================================================================
C** CRT_FILE - Create file with correct code page, authority &
everything.
C**================================================================
C CRT_FILE BEGSR
C EVAL Oflag = O_CREAT + O_CODEPAGE + O_RDWR
C EVAL Omode = S_IRWXU + S_IROTH
C EVAL FILENAME = %TRIM(FILENAME) + NULL
C EVAL ERR_FLAG = OPEN(%ADDR(FILENAME): OFLAG:
C OMODE: CODEPAGE)
C IF ERR_FLAG < 0
C EXSR EXIT
C ENDIF
C EVAL RC = CLOSE(ERR_FLAG)
C ENDSR
C**====================================================================
C** Just start adding to the OUTREC field. Each field separated by a comma
C** my fields are the XXXSRCNO and XXXDESC replace them with yours.
C**====================================================================
C BLDREC BEGSR
C EVAL NUM = %EDITC(XXXSRCNO:'P')
C EVAL outrec = %trim(OUTREC) +
C %trim(NUM) + ','
C EVAL outrec = %trim(OUTREC) +
C %trim(XXXDESC) + ','
C EVAL outrec = %TRIM(outrec) + EOLA
C ENDSR
C**====================================================================
C** OPN_FILE
C**====================================================================
C OPN_FILE BEGSR
C EVAL OFLAG = O_WRONLY + O_TEXTDATA
C EVAL ERR_FLAG = OPEN(%ADDR(FILENAME): OFLAG)
C IF ERR_FLAG < 0
C EXSR EXIT
C ENDIF
C ENDSR
C**====================================================================
C** WRT_IFS (yes, I know, convert this to buflen = %size(%trim(outrec))
C**====================================================================
C WRT_IFS BEGSR
C EVAL BufLen = %Len(%Trim(Outrec))
C EVAL RC = WRITE(ERR_FLAG: %ADDR(OUTREC): BUFLEN)
C
C CLEAR OUTREC
C ENDSR
C**====================================================================
C** Heading - Write out first Record with Column Headings
C**====================================================================
C HEADING BEGSR
C EVAL outrec = 'Source Number' + ',' +
C 'Description' + ',' +
C EOLA
C EXSR WRT_IFS
C ENDSR
C**==================================================================
C** EXIT - EXIT SUBROUTINE, Only Way Out Of Program
C**==================================================================
C EXIT BEGSR
C EVAL *INLR = *ON
C RETURN
C ENDSR
- ------------------
This is the /copy in all my IFS programs
- -----------
D*--------------------------------------------------------------------
D* ProtoTypes and definitions for working with the IFS
D*--------------------------------------------------------------------
D*
D*--------------------------------------------------------------------
D* OPEN - Open an IFS file
D*--------------------------------------------------------------------
D open PR 10I 0 EXTPROC('open')
D filename * VALUE
D openflags 10I 0 VALUE
D mode 10U 0 VALUE options(*nopass)
D codepage 10U 0 VALUE options(*nopass)
D*
D*---------------------------------------------------------------
D* ACCESS - Check for existance of an IFS file
D*---------------------------------------------------------------
D access PR 10I 0 EXTPROC('access')
D filename * VALUE
D modeI 10U 0 VALUE
D*
D*--------------------------------------------------------------------
D* READ - Read an IFS file
D*------------------------------------------------------------
D read PR 10I 0 EXTPROC('read')
D filehandle 10I 0 VALUE
D datarcved * VALUE
D nbytes 10U 0 VALUE
D*
D*------------------------------------------------------------
D* Write - Write record to IFS File
D*------------------------------------------------------------
D write PR 10I 0 EXTPROC('write')
D filehandle 10I 0 VALUE
D datatowrt * VALUE
D nbytes 10U 0 VALUE
D*
D*----------------------------------------------------------------
D* Close - Close IFS File
D*----------------------------------------------------------------
D close PR 10I 0 EXTPROC('close')
D filehandle 10I 0 VALUE
D*
D*---------------------------------------------------------------
D* Unlink - Delete IFS File
D*---------------------------------------------------------------
D unlink PR 10I 0 EXTPROC('unlink')
D filename * VALUE
D*
D*----------------------------------------------------------------
D* RC = IFS API Return code
D*----------------------------------------------------------------
D O_APPEND S 10I 0 INZ(256)
D O_CODEPAGE S 10I 0 INZ(8388608)
D O_CREAT S 10I 0 INZ(8)
D O_EXCL S 10I 0 INZ(16)
D O_RDONLY S 10I 0 INZ(1)
D O_RDWR S 10I 0 INZ(4)
D O_TEXTDATA S 10I 0 INZ(16777216)
D O_TRUNC S 10I 0 INZ(64)
D O_WRONLY S 10I 0 INZ(2)
D S_IRUSR S 10I 0 INZ(256)
D S_IWUSR S 10I 0 INZ(128)
D S_IXUSR S 10I 0 INZ(64)
D S_IRWXU S 10I 0 INZ(448)
D S_IRGRP S 10I 0 INZ(32)
D S_IWGRP S 10I 0 INZ(16)
D S_IXGRP S 10I 0 INZ(8)
D S_IRWXG S 10I 0 INZ(56)
D S_IROTH S 10I 0 INZ(4)
D S_IWOTH S 10I 0 INZ(2)
D S_IXOTH S 10I 0 INZ(1)
D S_IRWXO S 10I 0 INZ(7)
[report a broken link by clicking here]