|
midrange.com
Here's a sample from an article from MC.
* To * Compile:
*
* CRTBNDRPG PGM(XXX/PC001RG) DFTACTGRP(*NO) BNDDIR(QC2LE)
*================================================================
FPc001df CF E Workstn
FCstmst UF A E K Disk
FCstnote UF A E K Disk
/copy *LIBL/Qrpglesrc,ifsprotos
D Unlink PR 10i 0 ExtProc('unlink')
D filename * value
D RtvNetAds PR 20A
D Device 10A CONST
D CrtBldIfs PR 12A
D FileName 12A CONST
D RdIfsFil PR 12A
D FileName 12A CONST
D Apost C Const('''')
D CodePage S 10u 0 inz(819)
D Cr C const(x'0D')
D Create S 1A INZ('0')
D Data_Rec S 256A
D Eol C Const(x'0D25')
D Error_Flag S 1A INZ('0')
D Extension S 4A INZ('.RTF')
D File S 16a
D FileName S 16a
D File_Ext S 12A INZ
D File_Path S 16A INZ
D Fp S 10i 0
D I_Net_Adr S 20A Inz
D Lf C const(x'25')
D N S 5 0
D Oflag S 10i 0
D Omode S 10u 0
D R S 5 0
D Rc S 10i 0
D RmtCmd S 150 INZ
D Rmt_Len S 15 5 INZ(150)
D Rmt_Lit1 C Const('RUNRMTCMD CMD(''')
D Rmt_Lit2 C Const(''') RMTLOCNAME(''')
D Run_Cmd S 150 INZ
D Work150 S 150 INZ
D Wordpad_Lit C Const('Start /w
C:\Progra~1\Access~1-
D \Wordpad.exe')
D SDS
D Device 244 253
*---------------------------------------------------------
* MAIN
*---------------------------------------------------------
C Dow *In03 = *Off
C Exfmt Pc001
C If *In03 = *On
C Eval *Inlr = *On
C Return
C Endif
C If Cust# > 0
C Exsr Get_Cust
C Exsr Dtl_Scn
C Clear Cust#
C Endif
C Enddo
*---------------------------------------------------------
* Get_Cust - Get Customer Info
*---------------------------------------------------------
C Get_Cust Begsr
C Eval Notes = '0'
C Eval Save = '1'
C Eval Doc_Typ = '2'
C Eval Create = *On
C Eval File_Name = *Blanks
C Eval File_Ext = *Blanks
C Cust# Chain Cstmst 99
C If *In99 = *Off
* .
* . Load Screen Fields From Database
* .
C Eval Drive = Note_Drive
C Eval File_Name = NFile_Name
C Eval Doc_Typ = NFile_Type
C Endif
C Endsr
*---------------------------------------------------------
* Dtl_Scn - Display Detail Screen
*---------------------------------------------------------
C Dtl_Scn Begsr
C Dow *In03 = *Off
*
C Exfmt Pc002
C If *In03 = *On Or *In12 = *On
C If *In03 = *On
C Eval *Inlr = *On
C Return
C Endif
C Leave
C Endif
*
C If Notes > '0'
* Retrieve IP Address
C Eval I_Net_Adr = RtvNetAds(Device)
C Eval I_Net_Adr = %trim(I_Net_Adr)
C Eval Run_Cmd = Wordpad_Lit
C Eval File_Path = ' '
C Exsr Window
C Eval Notes = '0'
C Else
C Exsr Del_Old_Rec
C If Save = '2'
C Eval Error_Flag = RdIfsFil(File_Ext)
C Endif
C Exsr Update_Rec
C Leave
C Endif
*
C Enddo
C Endsr
*---------------------------------------------------------
* Window - Display Path Window
*---------------------------------------------------------
C Window Begsr
C Exfmt Pc00w1
C If *In12 = *Off
C If Doc_Typ = '1'
C Eval Extension = '.TXT'
C Else
C Eval Extension = '.RTF'
C Endif
C File_Name Cat Extension:0 File_Ext
C If Notes = '2'
C Eval Create = *On
C Endif
C Eval Error_Flag = CrtBldIfs(File_Ext)
* Build PC Command String
C If Error_Flag = *Off
C Eval File_Path = Drive + ':\' + File_Ext
C Run_Cmd Cat File_Path:1 Work150
C Eval Run_Cmd = %Triml(Work150)
C Exsr Run_PC_Cmd
C Endif
C Endif
C Endsr
*---------------------------------------------------------
* Run_Pc_Cmd - Run PC Command
*---------------------------------------------------------
C Run_Pc_Cmd Begsr
C Rmt_Lit1 Cat Run_Cmd:0 RmtCmd
C Cat Rmt_Lit2:0 RmtCmd
C Cat I_Net_Adr:0 RmtCmd
C Cat Apost:0 RmtCmd
C Cat Apost:1 RmtCmd
C Cat '*IP'')':0 RmtCmd
C Call 'QCMDEXC'
C Parm RmtCmd
C Parm Rmt_Len
C Endsr
*---------------------------------------------------------
* Upd_Rec - Add/Update Customer Info
*---------------------------------------------------------
C Update_Rec Begsr
C Cust# Chain Cstmst 99
C Eval Cust_No = Cust#
* .
* . Load Database From Screen Fields
* .
C Eval NFile_Name = File_Name
C Eval NFile_Type = Doc_Typ
C Eval Note_Drive = Drive
*
C If *In99 = *Off
C Update Rcstmst
C Else
C Write Rcstmst
C Endif
C Endsr
*---------------------------------------------------------
* Del_Old_Rec - Delete Old Note Records
*---------------------------------------------------------
C Del_Old_Rec Begsr
C Cust# Chain Cstnote 99
C Dow *In99 = *Off
C Delete Rcnote
C Cust# Reade Cstnote 99
C Enddo
C Endsr
*---------------------------------------------------------
* RtvNetAds - Subprocedure To Retrieve PC's IP Address
*---------------------------------------------------------
P RtvNetAds B Export
D RtvNetAds PI 20A
D Inp_Device 10A Const
D Apierr DS
D Bytprv 1 4B 0 Inz(216)
D Bytavl 5 8B 0 Inz
D Errid 9 15A Inz
D Rsvd 16 16A Inz
D Errdta 17 216A Inz
D Net_Address S 20A INZ
D Format S 8A Inz('DEVD0600')
D Rcvar S 5000A Inz
D Varlen S 4B 0 Inz(5000)
C Eval Device = Inp_Device
C Call 'QDCRDEVD'
C Parm Rcvar
C Parm Varlen
C Parm Format
C Parm Device
C Parm Apierr
C If BytAvl = 0
C Eval Net_Address = %Subst(Rcvar:877:16)
C Endif
C Return Net_Address
P RtvNetAds E
*---------------------------------------------------------
* CrtBldIfs - Subprocedure To Create/Build IFS File
*---------------------------------------------------------
P CrtBldIfs B Export
D CrtBldIfs PI 12A
D FileName 12A Const
C Eval File = %trim(FileName) + x'00'
C If Create = *On
C Eval Oflag = O_Creat + O_Codepage +
C O_Rdwr
C Eval Omode = S_Irwxu + S_Iroth
C Eval Fp = Open(%addr(File): Oflag:
C omode: CodePage)
C Eval Rc = Close(Fp)
C Endif
C Eval Data_Rec = *Blanks
C Eval Oflag = O_Wronly + O_Textdata
C Eval Fp = Open(%addr(File): Oflag)
C If Fp < 0
C Eval Error_Flag = *On
C Return Error_Flag
C Endif
* Read File By Customer Number and Write To IFS File
C Cust# Chain Cstnote 99
C Dow *In99 = *Off
C Eval Data_Rec = Text + EOL
C Eval Rc = Write(Fp: %Addr(Data_Rec):
C %Len(%Trimr(Data_Rec)))
C Cust# Reade Cstnote 99
C Enddo
C Eval Rc = Close(fp)
C Return Error_Flag
P CrtBldIfs E
*---------------------------------------------------------
* RdIfsFil - Subprocedure To Read The IFS File & Build DB
*---------------------------------------------------------
P RdIfsFil B Export
D RdIfsFil PI 12A
D FileName 12A Const
D CharsRead S 10i 0
D CurChar S 1
D Eof C const(x'00')
C Eval Oflag = O_Rdonly + O_Textdata
C Eval File = %trim(FileName) + x'00'
C Eval Fp = open(%addr(File): Oflag)
C If Fp < 0
C Eval Error_Flag = *On
C Return Error_Flag
C Endif
C Eval R = 0
C Eval N = 0
C Eval Data_Rec = *Blanks
C Exsr GetChar
C Dow CurChar <> Eof
C Select
C When R = 256
C Exsr Write_Note
C Eval R = *zero
C Eval Text = *blanks
C When CurChar = Cr
C Exsr Write_Note
C Eval R = *zero
C Eval Text = *blanks
C When CurChar = Lf
C Exsr Write_Note
C Eval R = *zero
C Eval Text = *blanks
C Other
C Eval R = R + 1
C Eval %Subst(Text: R: 1) = CurChar
C Endsl
C Exsr GetChar
C Enddo
C Exsr Write_Note
C CallP Close(Fp)
* Remove File From Folder Using The Unlink Procedure
C CallP Unlink(%addr(File))
C Return Error_Flag
*---------------------------------------------------------
* GetChar - Process IFS Record, One Character At A Time
*---------------------------------------------------------
C GetChar begsr
* If input buffer is empty, or all characters have been
* processed, refill the input buffer.
C If N = CharsRead
C Eval Data_Rec = *Blanks
C Eval CharsRead = Read(Fp:
C %Addr(Data_Rec): 256)
C Eval N = *Zero
C Endif
* Get the next character in the input buffer.
c If CharsRead <= 0
C Eval CurChar = Eof
C Else
C Eval N = N + 1
C Eval CurChar = %Subst(Data_Rec: N: 1)
C Endif
C Endsr
*---------------------------------------------------------
* Write_Note - Write Customer Note Record
*---------------------------------------------------------
C Write_Note Begsr
C Eval Note_Cust# = Cust#
C Write Rcnote
C Endsr
P RdIfsFil E
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* * Prototypes and definitions for working with the IFS
*
* Warning: this file may be incomplete or contain errors!
*
* open -- open an IFS file
*
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)
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* read -- read an IFS file
*
D read pr 10i 0 ExtProc('read')
D filehandle 10i 0 value
D datareceived * value
D nbytes 10u 0 value
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* write -- write to an IFS file
*
D write pr 10i 0 ExtProc('write')
D filehandle 10i 0 value
D datatowrite * value
D nbytes 10u 0 value
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* close- close an IFS file
*
D close pr 10i 0 ExtProc('close')
D filehandle 10i 0 value
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* values for oflag parameter, used by open()
* from QSYSINC/H, member FCNTL
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)
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
* user authorities for omode parameter, used by open()
* from QSYSINC/SYS, member STAT
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)
* group authorities
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)
* other authorities
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)
*
D Errno s 10a
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
A****************************************************************
A*
A* To Compile:
A* CRTDSPF FILE(xxx/PC001DF) SRCFILE(xxx/QDDSSRC) +
A* SRCMBR(PC001DF)
A*
A****************************************************************
A DSPSIZ(24 80 *DS3)
A PRINT
A CA03(03 'EXIT')
A CA12(12 'RETURN')
A R PC001
A 1 4USER
A 1 27'Customer Master Update'
A DSPATR(HI)
A DSPATR(UL)
A 1 62DATE
A EDTCDE(Y)
A 3 4'Customer #...........:'
A CUST# 8Y 0B 3 28CHECK(FE ER)
A EDTCDE(Z)
A DSPATR(HI)
A 24 4'F3=Exit'
A COLOR(BLU)
A R PC002
A 1 4USER
A 1 27'Customer Master Update'
A DSPATR(HI)
A DSPATR(UL)
A 1 62DATE
A EDTCDE(Y)
A 3 4'Customer #...........:'
A CUST# 8Y 0O 3 28EDTCDE(Z)
A DSPATR(HI)
A 5 4'Name.................:'
A CFNAME 15A B 5 28DSPATR(HI)
A CLNAME 30A B 5 45DSPATR(HI)
A 6 4'Address Line 1.......:'
A CADRS1 40A B 6 28DSPATR(HI)
A 7 4'Address Line 2.......:'
A CADRS2 40A B 7 28DSPATR(HI)
A 8 4'City.................:'
A CCITY 40A B 8 28DSPATR(HI)
A 9 4'State................:'
A CSTATE 2A B 9 28DSPATR(HI)
A 10 4'Zip + 4..............:'
A CZIP 5Y 0B 10 28CHECK(RZ)
A EDTCDE(Z)
A DSPATR(HI)
A 10 34'-'
A CZIP4 4Y 0B 10 36CHECK(RZ)
A DSPATR(HI)
A 12 4'Telephone............:'
A TELE 10A B 12 28DSPATR(HI)
A 13 4'Fax..................:'
A FAX 10A B 13 28DSPATR(HI)
A 14 4'E-Mail...............:'
A EMAIL 40A B 14 28DSPATR(HI)
A 17 4'Credit Limit.........:'
A CRDLMT 16Y 0B 17 28CHECK(FE)
A CHECK(RZ)
A EDTCDE(Z)
A DSPATR(HI)
A 19 4'Customer Notes:'
A NOTES 1A B 19 21DSPATR(HI)
A VALUES('0' '1' '2')
A 19 24'0=No Notes'
A 19 52'Save Notes In?:'
A SAVE 1A B 19 68DSPATR(HI)
A VALUES('1' '2')
A 19 70'1=Folder'
A 20 24'1=Get Notes From Folder'
A 20 70'2=Database'
A 21 24'2=Get Notes From Database'
A 24 4'F3=Exit'
A COLOR(BLU)
A 24 56'F12=Return/No Update'
A COLOR(BLU)
A R PC00W1
A WINDOW(*DFT 13 60)
A RMVWDW
A USRRSTDSP
A 2 14'Enter/Verify Notes File Path'
A DSPATR(HI)
A DSPATR(UL)
A 6 16'Drive Letter.:'
A DSPATR(HI)
A DRIVE 1A B 6 31
A 7 16'File Name....:'
A DSPATR(HI)
A FILE_NAME 8A B 7 31
A 8 16'File Type....:'
A DSPATR(HI)
A DOC_TYP 1A B 8 31
A 8 34'1=Text'
A 9 34'2=Rich Text Format'
A 11 3'F12=Return'
A COLOR(BLU)
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
***************************************************************
*
* To Compile:
* CRTPF FILE(xxx/CSTMST) SRCFILE(xxx/QDDSSRC) +
* MBR(CSTMST)
*
***************************************************************
A R RCSTMST TEXT('CUSTOMER MASTER')
A CUST_NO 8 0 TEXT('CUSTOMER #')
A FIRST_NAME 15 TEXT('FIRST NAME')
A LAST_NAME 30 TEXT('LAST NAME')
A ADDRESS_1 40 TEXT('ADDRESS LINE 1')
A ADDRESS_2 40 TEXT('ADDRESS LINE 2')
A CITY 40 TEXT('CITY')
A STATE 2 TEXT('STATE')
A ZIP 5 0 TEXT('ZIP')
A ZIP4 4 0 TEXT('ZIP + 4')
A TELEPHONE 10 TEXT('TELEPHONE #')
A FAX_NO 10 TEXT('FAX NUMBER')
A E_MAIL 40 TEXT('E-MAIL ADDRESS')
A CREDIT_LMT 16 2 TEXT('CREDIT LIMIT')
A NOTE_DRIVE 1 TEXT('DRIVE')
A NFILE_NAME 8 TEXT('NOTES FILE NAME')
A NFILE_TYPE 1 TEXT('DOCUMENT TYPE')
*
A K CUST_NO
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
***************************************************************
*
* To Compile:
* CRTPF FILE(xxx/CSTNOTE) SRCFILE(xxx/QDDSSRC) +
* MBR(CSTNOTE)
*
***************************************************************
A R RCNOTE TEXT('CUSTOMER MASTER NOTES')
A NOTE_CUST# 8 0 TEXT('CUSTOMER #')
A TEXT 256 TEXT('NOTE TEXT')
A TEXT2 256 TEXT('NOTE TEXT')
*
A K NOTE_CUST#
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
----- Original Message -----
From: <rob@dekko.com>
To: <midrange-l@midrange.com>
Sent: Monday, October 08, 2001 11:10 AM
Subject: Re: QNTC
>
> I wouldn't mind seeing some sample's. When I tried playing around with
IFS
> access with RPG, even out of the redbook, I could never get it to work.
>
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.
