Tweet
Ok, I received some positive feedback from the CMDTOOLS utility, so I thought I would paste my favorite utility for interactive RPG programs. This is the MSGTOOLS utility which makes handling messages in RPG easier.
(You need to have CMDTOOLS working to use this one.)
1. First, create a copy book with the following member in it, somewhere in your compile library list. (name the member MSGTOOLS)
2. Create a source member called MSGTOOLS in QRPGLESRC for the procedure source.
3. Ok, compile the module using option 15.
4. Create a binding directory called MSGTOOLS and add an entry to the directory for this new module.
Now your ready to create a screen.
I'll post an example as a reply...
(You need to have CMDTOOLS working to use this one.)
1. First, create a copy book with the following member in it, somewhere in your compile library list. (name the member MSGTOOLS)
Code:
*****************************************************************
* *
* Copy Book for procedures defined in the service program *
* MSGTOOLS *
* *
*****************************************************************
D SendMsg PR
D Id 7 VALUE
D Data 80 VALUE OPTIONS(*NOPASS)
D File 10 VALUE OPTIONS(*NOPASS)
D Library 10 VALUE OPTIONS(*NOPASS)
D SendMsgText PR
D Message 80 VALUE
D SendEscMsg PR
D Message 80A VALUE
D SendStsMsg PR
D Message 80A VALUE
D DspMsgs PR
D ClearMsgs PR
D ClearLastMsg PR
D RtvMsgText PR 80
D Id 7 VALUE
D Data 80 VALUE OPTIONS(*NOPASS)
D File 10 VALUE OPTIONS(*NOPASS)
D Library 10 VALUE OPTIONS(*NOPASS)
D RetrieveCaller PR 10A
Code:
H OPTION(*NODEBUGIO:*SRCSTMT) DEBUG(*YES) NOMAIN
H BNDDIR('CMDTOOLS')
*****************************************************************
* *
* Service Program Name: MsgTools *
* Author .............: Soup Dog *
* Date Written .......: January 10, 2007 *
* Description ........: This service program contains *
* routines to make the handling of *
* messages easier. *
* *
*****************************************************************
*----------------------------------------------------------------
* Variable declarations.
*----------------------------------------------------------------
D Msg DS QUALIFIED
D Id 7 INZ
D Data 80 INZ
D File 10 INZ
D Library 10 INZ
D ErrorDS ds 16
D BytesProv 10i 0 inz(16)
D BytesAvail 10i 0
D ExceptionID 7
D RetrieveMsgQ PR 10A
* Program Status Data Structure.
D RPGDS SDS 429
D Program *PROC
D Routine *ROUTINE
D JobName 244 253
D User 254 263
D JobNumber 264 269 0
D ProcessPgm 334 343
D ProcessMod 344 353
* Procedure definitions.
/COPY QCPYSRC,MsgTools
/COPY QCPYSRC,CmdTools
D setScreenWidth PR
D SendPgmMsg pr extpgm('QMHSNDPM')
D MsgID 7 CONST
D MsgFile 20 CONST
D MsgDta 80 CONST
D MsgDtaLen 10i 0 CONST
D MsgType 10 CONST
D MsgQ 10 CONST
D MsgQNbr 10i 0 CONST
D MsgKey 4
D ErrorDS 16
D MsgKey s 4
D MsgLevel s 3s 0 INZ(1)
*****************************************************************
* *
* SendMsg Procedure *
* *
*****************************************************************
P SendMsg B EXPORT
D SendMsg PI
D P_MsgId VALUE LIKE(Msg.Id)
D P_MsgData VALUE LIKE(Msg.Data) OPTIONS(*NOPASS)
D P_MsgFile VALUE LIKE(Msg.File) OPTIONS(*NOPASS)
D P_MsgLibrary VALUE LIKE(Msg.Library)
D OPTIONS(*NOPASS)
C IF %PARMS > 3
C EVAL Msg.Library = P_MsgLibrary
C ELSE
C EVAL Msg.Library = '*LIBL'
C ENDIF
C IF %PARMS > 2
C EVAL Msg.File = P_MsgFile
C ELSEIF %SUBST(P_MsgId:1:3) = 'CPF'
C EVAL Msg.File = 'QCPFMSG'
C ELSE
C EVAL Msg.File = 'HILLMSGF'
C ENDIF
C IF %PARMS > 1
C EVAL Msg.Data = P_MsgData
C ELSE
C EVAL Msg.Data = *BLANKS
C ENDIF
C EVAL Msg.Id = P_MsgId
C IF Msg.Id = *BLANKS AND
C Msg.Data <> *BLANKS
C EVAL Msg.Id = 'CPDA0FF'
C EVAL Msg.File = 'QCPFMSG'
C ENDIF
C callp SendPgmMsg (Msg.id:
C Msg.File + Msg.Library:
C Msg.Data:
C %len(Msg.Data):
C '*INFO':
C '*':
C MsgLevel:
C MsgKey:
C ErrorDS)
C RETURN
P E
*****************************************************************
* *
* SendMsgText Procedure *
* *
*****************************************************************
P SendMsgText B EXPORT
D SendMsgText PI
D P_MsgData LIKE(Msg.Data) VALUE
C callp SendPgmMsg ('CPDA0FF':
C 'QCPFMSG *LIBL ':
C P_MsgData:
C %len(P_MsgData):
C '*INFO':
C '*':
C MsgLevel:
C MsgKey:
C ErrorDS)
C return
P E
*****************************************************************
* *
* SendEscMsg Procedure *
* *
*****************************************************************
P SendEscMsg B EXPORT
D SendEscMsg PI
D P_MsgData 80a VALUE
C callp SendPgmMsg ('CPA2401':
C 'QCPFMSG *LIBL ':
C P_MsgData:
C %len(P_MsgData):
C '*ESCAPE':
C '*':
C MsgLevel:
C MsgKey:
C ErrorDS)
C return
P E
*****************************************************************
* *
* SendStsMsg Procedure *
* *
*****************************************************************
P SendStsMsg B EXPORT
D SendStsMsg PI
D P_MsgData 80a VALUE
C callp SendPgmMsg ('CPDA0FF':
C 'QCPFMSG *LIBL ':
C P_MsgData:
C %len(P_MsgData):
C '*STATUS':
C '*EXT':
C 0:
C MsgKey:
C ErrorDS)
C return
P E
*****************************************************************
* *
* DspMsgs Procedure *
* *
*****************************************************************
P DspMsgs B EXPORT
D DspMsgs PI
C Callp RunCommand('DSPMSG')
C RETURN
P E
*****************************************************************
* *
* ClearMsgs Procedure *
* *
*****************************************************************
P ClearMsgs B EXPORT
D ClearMsgs PI
D QmhRmvPM PR ExtPgm('QMHRMVPM')
D CallStackEntry 64A CONST OPTIONS(*VARSIZE)
D CallStackCount 10I 0 CONST
D MsgKey 4A CONST
D MsgToRemove 10A CONST
D ErrorDS 16
/free
QMHRMVPM('*' : MsgLevel : ' ' : '*ALL' : ErrorDS);
return;
/end-free
P E
*****************************************************************
* *
* ClearLastMsg Procedure *
* *
*****************************************************************
P ClearLastMsg B EXPORT
D ClearLastMsg PI
D MsgData S LIKE(Msg.Data)
d msglen s 10I 0 inz
d cstkcn s 10I 0 inz
d waittm s 10I 0 inz
C CALL(E) 'QMHRCVPM'
C PARM MsgData
C PARM 80 MSGLEN
C PARM 'RCVM0200' FMTNAM 8
C PARM '*' CSTKEN 10
C PARM msgLevel CSTKCN
C PARM '*LAST' MSGTYP 10
C PARM *BLANKS MSGKEY 4
C PARM WAITTM
C PARM '*REMOVE' MSGACT 10
C PARM Errords
P E
*****************************************************************
* *
* RtvMsgText Procedure *
* *
*****************************************************************
P RtvMsgText B EXPORT
D RtvMsgText PI 80
D P_MsgId VALUE LIKE(Msg.Id)
D P_MsgData VALUE LIKE(Msg.Data) OPTIONS(*NOPASS)
D P_MsgFile VALUE LIKE(Msg.File) OPTIONS(*NOPASS)
D P_MsgLibrary VALUE LIKE(Msg.Library)
D OPTIONS(*NOPASS)
* API error data structure.
D ErrorAPI DS Qualified
D ByteProv 9B 0 INZ(%SIZE(ErrorAPI.msgdata))
D BytesAval 9B 0 INZ(%SIZE(ErrorAPI.msgdata))
D Msgid 7A INZ(*BLANKS)
D Filler 1A INZ(*BLANKS)
D MsgData 256A INZ(*BLANKS)
* RTVM0100 Format
D Text DS Qualified
D BytesRet 9B 0 INZ(0)
D BytesProv 9B 0 INZ(0)
D LenRet 9B 0 INZ(0)
D LenAva 9B 0 INZ(0)
D LenHelpRet 9B 0 INZ(0)
D LenHelpAva 9B 0 INZ(0)
D MsgText 80 INZ(*BLANKS)
D MsgHelp 256 INZ(*BLANKS)
* Parm fields for retrieve text prototype
D TextLength S 9B 0 INZ(%Len(Text))
D Format S 8 INZ('RTVM0100')
D MessageId S 7
D MessageFile DS
D MsgFile 10
D MsgLib 10
D Data S LIKE(Msg.Data)
D DataLength S 9B 0 INZ(%LEN(Data))
D SubstValues S 10 INZ('*YES')
D ReturnFormat S 10 INZ('*YES')
* Procedure definitions for retrieving the message text.
D QMHRTVM PR EXTPGM('QMHRTVM')
D parm1 LIKE(Text)
D parm2 LIKE(TextLength)
D parm3 LIKE(Format)
D parm4 LIKE(MessageId)
D parm5 LIKE(MessageFile)
D parm6 LIKE(Data)
D parm7 LIKE(DataLength)
D parm8 LIKE(SubstValues)
D parm9 LIKE(ReturnFormat)
D parm10 LIKE(ErrorAPI)
C IF %PARMS > 3
C EVAL MsgLib = P_MsgLibrary
C ELSE
C EVAL MsgLib = '*LIBL'
C ENDIF
C IF %PARMS > 2
C EVAL MsgFile = P_MsgFile
C ELSEIF %SUBST(P_MsgId:1:3) = 'CPF' Or
C %SUBST(P_MsgId:1:3) = 'CPD'
C EVAL MsgFile = 'QCPFMSG'
C ELSE
C EVAL MsgFile = 'HILLMSGF'
C ENDIF
C IF %PARMS > 1
C EVAL Data = P_MsgData
C ELSE
C EVAL Data = *BLANKS
C ENDIF
C EVAL MessageId = P_MsgId
C IF MessageId = *BLANKS AND
C Data <> *BLANKS
C EVAL MessageId = 'CPDA0FF'
C EVAL MsgFile = 'QCPFMSG'
C ENDIF
C CALLP QMHRTVM(Text:TextLength:Format:
C MessageId:MessageFile:
C Data:DataLength:SubstValues:
C ReturnFormat:ErrorAPI)
C RETURN Text.MsgText
P E
*****************************************************************
* Retrieve Caller Procedure. *
*****************************************************************
P RetrieveCaller B EXPORT
D RetrieveCaller PI 10A
* Field definitions for retrieving the call stack entry.
D rtvCallStack DS Qualified
D Receiver LIKE(CSTK0100) INZ
D Length 9B 0 inz(%size(rtvCallStack.Receiver))
D Format 8A inz('CSTK0100')
D JobId LIKE(JIDF0100) INZ
D JobIdFormat 8A inz('JIDF0100')
D Error LIKE(APIError) INZ
D JIDF0100 DS Qualified
D Name 10A INZ('*')
D User 10A INZ(*BLANKS)
D Number 6A INZ(*BLANKS)
D Id 16A
D Reserved 2A INZ(*LOVAL)
D ThreadIndic 9B 0 INZ(1)
D ThreadId 8A INZ(*LOVAL)
D CSTK0100 DS 5000 Qualified inz
D BytesReturned 9B 0
D BytesAvail 9B 0
D #ofEntries 9B 0
D StackOffset 9B 0
D #Returned 9B 0
D StackEntry DS 256 Qualified inz
D Length 9B 0
D StatementDisp 9B 0
D #ofIds 9B 0
D ProcedureDisp 9B 0
D LenProcedure 9B 0
D RequestLevel 9B 0
D ProgramName 10A
D ProgramLib 10A
D Instruction# 9B 0
D ModuleName 10A
D ModuleLib 10A
D Boundary 1A
D Reserved1 3A
D ActGroup# 9B 0
D ActGroupName 10A
* Procedure definitions for the retrieve call stack entry API.
D QWVRCSTK PR EXTPGM('QWVRCSTK')
D Parm1 LIKE(rtvCallStack.Receiver)
D Parm2 LIKE(rtvCallStack.Length)
D Parm3 LIKE(rtvCallStack.Format)
D Parm4 LIKE(rtvCallStack.JobId)
D Parm5 LIKE(rtvCallStack.JobIdFormat)
D Parm6 LIKE(rtvCallStack.Error)
* API Error Data structure.
D APIError DS INZ Qualified
D ByteProv 9B 0 INZ(%SIZE(APIError.msgdata))
D Bytesaval 9B 0
D Msgid 7A
D Filler 1A
D MsgData 100A
D Offset S 7P 0
* Get API to get the call stack.
C EVAL rtvCallStack.Receiver = CSTK0100
C EVAL rtvCallStack.JobId = JIDF0100
C CALLP QWVRCSTK(rtvCallStack.Receiver:
C rtvCallStack.Length:
C rtvCallStack.Format:
C rtvCallStack.jobId:
C rtvCallStack.jobIdFormat:
C rtvCallStack.Error)
C EVAL CSTK0100 = rtvCallStack.Receiver
C EVAL Offset = CSTK0100.StackOffset + 1
* Get the first call stack entry. This will be the name of
* the calling procedure
C EVAL StackEntry = %SUBST(CSTK0100:Offset)
* Get the next call stack entry. This will be the name of the
* service program.
C EVAL Offset = Offset + StackEntry.Length
C EVAL StackEntry = %SUBST(CSTK0100:Offset)
* Get the next call stack entry. This should be the calling
* program.
C EVAL Offset = Offset + StackEntry.Length
C EVAL StackEntry = %SUBST(CSTK0100:Offset)
* Get the next call stack entry. This should be the name of the
* program that called the calling program.
C EVAL Offset = Offset + StackEntry.Length
C EVAL StackEntry = %SUBST(CSTK0100:Offset)
C Return StackEntry.ProgramName
P E
4. Create a binding directory called MSGTOOLS and add an entry to the directory for this new module.
Now your ready to create a screen.
I'll post an example as a reply...
Comment