|
midrange.com
I sort of hesitate to give this away, but this is exactly what you need and
more.
feel free to butcher my already butchered code
Cut and paste this into notepad, save it, Ftp it to your AS/400.
Good idea to deskcheck this before you compile and run it.
<<--- Cut here --->>
FDLTSPLBFM CF E WorkStn Sfile(Sfl1:Sfl1RRN)
DPgmSts SDS
D CPFID 40 46
D CPFMsg 91 170
D*Dta S 70 Dim(11) CtData PerRcd(1)
DErrRpt S 70
D MSGDTA S 70 Inz(*blanks)
D MSGID S 7 Inz('CPF9898')
D MSGTYP S 10 Inz('*STATUS')
D CSTACK S 9B 0 Inz(0)
D MSGDTL S 9B 0 Inz(70)
D MSGFIL S 20 Inz('QCPFMSG QSYS')
D MSGKEY S 9B 0
D CMSGQ S 10 Inz('*EXT')
*File layout for SPLF0100 format.
DListDS DS
D Rec 82A
D RecName 10A Overlay(Rec:1)
D RecOutQ 10A Overlay(Rec:11)
D RecQLib 10A Overlay(Rec:21)
D RecFmTyp 10A Overlay(Rec:31)
D RecUsrDta 10A Overlay(Rec:41)
D RecIntId 16A Overlay(Rec:51)
D RecIntSplId 16A Overlay(Rec:66)
*DS to get offset in.
DGeneralDS DS 140 Inz
D InputSize 113 116B 0
D ListOffset 125 128B 0
D NumberOfList 133 136B 0
D EntrySize 137 140B 0
D StartPosit S 9B 0
D StartLen S 9B 0
*API error data structure.
DErrorDS DS 116
D BytesProvd 1 4B 0
D BytesAvail 5 8B 0
D MessageId 9 15A
D Err# 16 16A
D MessageDta 17 116A
DInputDS DS Inz
D UserSpace 20
D SpaceName 10 OverLay(UserSpace:1)
D Inz('OIDLT002')
D SpaceLib 10 OverLay(UserSpace:11)
D Inz('QTEMP')
DFormatName S 8
DFormType S 10
DUserData S 10
DUserName S 10 Inz('*ALL')
DSpaceSize S 9B 0
DSpaceAttr S 10
DSpaceValue S 1
DSpaceAuth S 10 Inz('*CHANGE')
DSpaceText S 50
DSpaceReplc S 10 Inz('*YES')
D DS
D OutSpool 20
D OutQ 10 Overlay(OutSpool:1)
D QLib 10 Overlay(OutSpool:11)
DCurDir C const('/QIBM/UserData/RDARS-
D /SpoolFile/')
DLnkPth S 50A
DRmvLnk C const('RMVLNK OBJLNK('' -
D -
D ')
DCommand DS
D Cmd 70A
D Lnk 50A Overlay(Cmd:16)
DLen S 15 5 Inz(80.0)
DIndex S Like(NumberOfList) Inz(1)
*Initialization: Setup screen
* Setup user space
* Get archive to delete
C eval Keys1 = ('F3=Exit F12=Cancel')
C eval *In50 = *off
C dow not *InKC
C exsr CrtList
C if *InKC
C leave
C endif
C eval Cmd = RmvLnk
*Initialization:
C enddo
C eval *Inlr = *on
C return
*--------------------------------------------------------------*
* lodsfl() Load List into subfile *
*--------------------------------------------------------------*
CSR lodsfl begsr
C dow not *In50
*Get list
C if Index > NumberOfList
C eval *In50 = *on
C leave
C endif
C call 'QUSRTVUS'
C parm UserSpace
C parm StartPosit
C parm StartLen
C parm ListDS
C parm ErrorDS
C if MessageID <> *blanks
C eval *In50 = *on
C leave
C endif
C eval Index = (Index + 1)
C eval Sfl1RRN = (Sfl1RRN + 1)
C eval StartPosit = (StartPosit + EntrySize)
C enddo
CSR endsr
*--------------------------------------------------------------*
* crtlist() Create list of spoolfiles in Userspace. *
*--------------------------------------------------------------*
CSR CrtList begsr
C eval SpaceSize = 1024
C eval OutQ = 'ERROR'
C eval QLib = 'QUSRRDARS'
C call 'QUSCRTUS'
C parm UserSpace
C parm *blanks SpaceAttr
C parm SpaceSize
C parm *blanks SpaceValue
C parm '*ALL' SpaceAuth
C parm *blanks SpaceText
C parm '*YES' SpaceReplc
C parm ErrorDS
C call 'QUSLSPL'
C parm UserSpace
C parm 'SPLF0100' FormatName
C parm UserName
C parm OutSpool
C parm '*ALL' FormType
C parm '*ALL' UserData
C parm ErrorDS
C eval StartPosit = 1
C eval StartLen = 140
*Get offset to first record in user space.
C call 'QUSRTVUS'
C parm UserSpace
C parm StartPosit
C parm StartLen
C parm GeneralDS
C parm ErrorDS
C eval StartPosit = (ListOffset + 1)
C eval StartLen = EntrySize
CSR endsr
*--------------------------------------------------------------*
* sndmsg() - Send Program Message. *
*--------------------------------------------------------------*
CSR SndMsg begsr
START SNDMSG()
C call 'QMHSNDPM'
SNDPGMMSG API
C parm MsgID
C parm MsgFil
C parm MsgDta
C parm 70 MsgDtl
C parm MsgTyp
C parm CMsgQ
C parm CStack
C parm MsgKey
C parm ErrorDS
CSR endsr
END SNDMSG()
*--------------------------------------------------------------*
* *PSSR() - PROGRAM EXECPTION ERROR HANDLER ROUTINE *
*--------------------------------------------------------------*
CSR *PSSR begsr
START *PSSR()
C eval MsgID = CPFID
C eval MsgTyp = '*INFO'
C eval MsgDta = CPFMsg
C eval CMsgQ = '*EXT'
C eval CStack = 0
C exsr Sndmsg
C eval *InLR = *on
C return
CSR endsr
END *PSSR
<<--- End here --->>
Chris Bipes wrote:
> There are APIs to list the spool files in an out queue. The one I used in
> the past listed all the spool files and their attributes. I can not
> remember the exact api but hear is the book with all the spool file apis:
>
> AS/400e
> System API Reference
> OS/400 Print APIs
> Version 4
> Document Number SC41-5874-03
>
> Have fun,
>
> Christopher K. Bipes mailto:ChrisB@Cross-Check.com
> Sr. Programmer/Analyst mailto:Chris_Bipes@Yahoo.com
> CrossCheck, Inc. http://www.cross-check.com
> 6119 State Farm Drive Phone: 707 586-0551 x 1102
> Rohnert Park CA 94928 Fax: 707 586-1884
>
> *Note to Recruiters
> Neither I, nor anyone that I know of, is interested in any new and/or
> exciting positions. Please do not contact me.
>
> -----Original Message-----
> From: Mary Spencer [mailto:Mspence@pop3.utoledo.edu]
> Sent: Friday, December 10, 1999 10:13 AM
> To: Midrange-L
> Subject: CPYSPLF
>
> I want to use the descriptions of spool files in an outq in a CL
> program. Anyone know how I can do this? I am trying to automate
> copying a good number of spool files to physical files for downloading.
> Or ..... is there and easier way to do this?
> --
> Mary :-)
>
> せカせЙせカせЙせカせЙせカせЙせカせЙせカ
> Mary Spencer
> Director of information Services
> University of Toledo Foundation
>
> "For every problem there is one solution which is simple,
> neat and wrong." H. L. Mencken
> せカせЙせカせЙせカせЙせカせЙせカせЙせカ
> +---
> | 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
> +---
--
L. S. Russell Programmer/Analyst
Datrek Professional Bags, Inc.
2413 Industrial Drive
Springfield, TN. 37172
mailto:leslier@datrek.com
http://www.datrek.com
--
+---
| 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-2024 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.
