|
midrange.com
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 work for youl. 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 EOLA SCAN OUTREC:1 STR
C EVAL BufLen = (STR + 1)
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* 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* 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)
+---
| This is the Midrange System Mailing List!
| To submit a new message, send your mail to MIDRANGE-L@midrange.com.
| To subscribe to this list send email to MIDRANGE-L-SUB@midrange.com.
| To unsubscribe from this list send email to MIDRANGE-L-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: david@midrange.com
+---
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2025 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
