Messagebox

Messagebox like in Microsoft Windows.

Copymember
// Input parameters :
// - Title
// - Message
// - Message type (Avaible buttons
// - Stating row
// - Starting column
// - Window size (Small/Medium/Large)
// - Word-Wrap
// Output param.:
// - Used button
//
// /free
// @return = msgBox('Test title':'Messagetext'
// :cMSGBOX_yesNo);
//
// @return = msgBox('Confirm'
// :@msgBoxText
// :cMSGBOX_okCancel
// :10
// :6
// :cMSGBOX_medium
// :cMSGBOX_noWrap);
// /end-free
//
//*******************************************************************

//--------------------------------------------------------------------
// constants
//--------------------------------------------------------------------
// Message types
d cMSGBOX_ok c 1
d cMSGBOX_okCancel...
d c 2
d cMSGBOX_abortRetryIgnore...
d c 3
d cMSGBOX_yesNoCancel...
d c 4
d cMSGBOX_yesNo c 5
d cMSGBOX_retryCancel...
d c 6

// Message Sizes
d cMSGBOX_small...
d c 1
d cMSGBOX_medium...
d c 2
d cMSGBOX_large...
d c 3

// Word-Wrap
d cMSGBOX_wrap...
d c 1
d cMSGBOX_noWrap...
d c 2

// Return values
d cMSGBOX_returnOk...
d c 1
d cMSGBOX_returnCancel...
d c 2
d cMSGBOX_returnRetry...
d c 3
d cMSGBOX_returnIgnore...
d c 4
d cMSGBOX_returnAbort...
d c 5
d cMSGBOX_returnYes...
d c 6
d cMSGBOX_returnNo...
d c 7

//--------------------------------------------------------------------
// prototypes
//--------------------------------------------------------------------
d msgBox...
d pr 1s 0
d @title 20a value
d @message 540a value
d @type 1s 0 value
d @xPos 2s 0 value options(*nopass)
d @yPos 2s 0 value options(*nopass)
d @size 1s 0 value options(*nopass)
d @wrap 1s 0 value options(*nopass)

Source

h noMain
fmsgbox cf e workstn usropn prefix(d1_) infds(@infDs)
//--------------------------------------------------------------------
// meta definition
//--------------------------------------------------------------------
/copy *libl/rguRpgCpy,rguKeyCpy

d BUTTONS_ ds qualified based(nullPtr)
d text 14a dim(3)
d rtnVal 1s 0 dim(3)
d f12 1s 0

//--------------------------------------------------------------------
// procedure prototypes
//--------------------------------------------------------------------
// prototypes algemeen:
/copy *libl/rguRpgCpy,msgBox

//--------------------------------------------------------------------
// globale variabelen (module niveau)
//--------------------------------------------------------------------
d @userId s 10a inz(*user)

d @infDs ds
d @keyPressed 369 369

d #buttons ds qualified
d text 276 Inz('OK +
d --------------+
d --------------+
d 1000+
d Ok +
d Cancel (F12) +
d --------------+
d 1202+
d Retry +
d Ignore +
d Cancel (F12) +
d 3453+
d Yes +
d No +
d Cancel (F12) +
d 6723+
d Yes +
d No (F12) +
d --------------+
d 6702+
d Retry +
d Cancel (F12) +
d --------------+
d 4202')
d type overlay(#buttons) dim(6)
d likeds(BUTTONS_)
//********************************************************************
// controle
//********************************************************************
p msgBox...
p b export
d pi 1s 0
d @title 20a value
d @message 540a value
d @type 1s 0 value
d @xPos 2s 0 value options(*nopass)
d @yPos 2s 0 value options(*nopass)
d @size 1s 0 value options(*nopass)
d @wrap 1s 0 value options(*nopass)
//Lokale variabelen
d @result s 1s 0

/free

//Bepalen positie
if %parms < 5;
d1_x = 10;
d1_y = 10;
else;
d1_x = @xPos;
d1_y = @yPos;
endif;

//Set title to display
d1_title = @title;

//Active buttons and button text
*in01 = #buttons.type(@type).rtnVal(1)<>0;
*in02 = #buttons.type(@type).rtnVal(2)<>0;
*in03 = #buttons.type(@type).rtnVal(3)<>0;
d1_btnText1 = #buttons.type(@type).text(1);
d1_btnText2 = #buttons.type(@type).text(2);
d1_btnText3 = #buttons.type(@type).text(3);

//F12 button
*in04 = #buttons.type(@type).f12<>0;

// Open displayfile
if not %open(msgBox);
open msgBox;
endif;
select;
when %parms < 6 or @size = cMSGBOX_small;
d1_msgSmall = @message;
if %parms = 7 and @wrap = cMSGBOX_noWrap;
exFmt rSmall;
else;
exFmt rSmallW;
endif;
when @size = cMSGBOX_medium;
d1_msgMedium = @message;
if %parms = 7 and @wrap = cMSGBOX_noWrap;
exFmt rMedium;
else;
exFmt rMediumW;
endif;
when @size = cMSGBOX_large;
d1_msgLarge = @message;
if %parms = 7 and @wrap = cMSGBOX_noWrap;
exFmt rLarge;
else;
exFmt rLargeW;
endif;
endsl;
close msgBox;

//Return value
select;
when @keyPressed = ENTER;
if d1_rtnVal <> 0;
@result = #buttons.type(@type).rtnVal(d1_rtnVal);
else;
@result = 0;
endif;
when @keyPressed = F12;
return #buttons.type(@type).rtnVal(#buttons.type(@type).f12);
endsl;

return @result;

/end-free
p e

Display file

A DSPSIZ(24 80 *DS3)
A INDARA
A WDWBORDER((*COLOR WHT) (*DSPATR RI)-
A (*CHAR '+-+||+-+'))
A 04 CA12
A*----------------------------------------------------------------
A R RSMALL
A OVERLAY
A WINDOW(&Y &X 8 60)
A KEEP
A WDWTITLE((*TEXT &TITLE))
A RTNVAL 2Y 0B 6 3PSHBTNFLD(*RSTCSR (*NUMCOL 3) (*GUT-
A TER 4))
A CHCAVAIL((*COLOR GRN))
A CHCUNAVAIL((*DSPATR ND))
A 01 PSHBTNCHC(1 &BTNTEXT1)
A 02 PSHBTNCHC(2 &BTNTEXT2)
A 03 PSHBTNCHC(3 &BTNTEXT3)
A X 2S 0P
A Y 2S 0P
A TITLE 20A P
A BTNTEXT1 14A P
A BTNTEXT2 14A P
A BTNTEXT3 14A P
A MSGSMALL 180A B 2 1CNTFLD(60)
A DSPATR(PR)
A 10 DSPATR(UL)
A R RSMALLW
A WINDOW(&Y &X 8 60)
A OVERLAY
A KEEP
A WDWTITLE((*TEXT &TITLE))
A RTNVAL 2Y 0B 6 3PSHBTNFLD(*RSTCSR (*NUMCOL 3) (*GUT-
A TER 4))
A CHCAVAIL((*COLOR GRN))
A CHCUNAVAIL((*DSPATR ND))
A 01 PSHBTNCHC(1 &BTNTEXT1)
A 02 PSHBTNCHC(2 &BTNTEXT2)
A 03 PSHBTNCHC(3 &BTNTEXT3)
A X 2S 0P
A Y 2S 0P
A TITLE 20A P
A BTNTEXT1 14A P
A BTNTEXT2 14A P
A BTNTEXT3 14A P
A MSGSMALL 180A B 2 1CNTFLD(060)
A WRDWRAP
A DSPATR(PR)
A 10 DSPATR(UL)
A*----------------------------------------------------------------
A R RMEDIUM
A OVERLAY
A WINDOW(&Y &X 11 60)
A KEEP
A WDWTITLE((*TEXT &TITLE))
A RTNVAL 2Y 0B 9 3PSHBTNFLD(*RSTCSR (*NUMCOL 3) (*GUT-
A TER 4))
A CHCAVAIL((*COLOR GRN))
A CHCUNAVAIL((*DSPATR ND))
A 01 PSHBTNCHC(1 &BTNTEXT1)
A 02 PSHBTNCHC(2 &BTNTEXT2)
A 03 PSHBTNCHC(3 &BTNTEXT3)
A X 2S 0P
A Y 2S 0P
A TITLE 20A P
A BTNTEXT1 14A P
A BTNTEXT2 14A P
A BTNTEXT3 14A P
A MSGMEDIUM 360A B 2 1CNTFLD(60)
A DSPATR(PR)
A 10 DSPATR(UL)
A R RMEDIUMW
A WINDOW(&Y &X 11 60)
A OVERLAY
A KEEP
A WDWTITLE((*TEXT &TITLE))
A RTNVAL 2Y 0B 9 3PSHBTNFLD(*RSTCSR (*NUMCOL 3) (*GUT-
A TER 4))
A CHCAVAIL((*COLOR GRN))
A CHCUNAVAIL((*DSPATR ND))
A 01 PSHBTNCHC(1 &BTNTEXT1)
A 02 PSHBTNCHC(2 &BTNTEXT2)
A 03 PSHBTNCHC(3 &BTNTEXT3)
A X 2S 0P
A Y 2S 0P
A TITLE 20A P
A BTNTEXT1 14A P
A BTNTEXT2 14A P
A BTNTEXT3 14A P
A MSGMEDIUM 360A B 2 1CNTFLD(060)
A WRDWRAP
A DSPATR(PR)
A 10 DSPATR(UL)
A*----------------------------------------------------------------
A R RLARGE
A OVERLAY
A WINDOW(&Y &X 14 60)
A KEEP
A WDWTITLE((*TEXT &TITLE))
A RTNVAL 2Y 0B 12 3PSHBTNFLD(*RSTCSR (*NUMCOL 3) (*GUT-
A TER 4))
A CHCAVAIL((*COLOR GRN))
A CHCUNAVAIL((*DSPATR ND))
A 01 PSHBTNCHC(1 &BTNTEXT1)
A 02 PSHBTNCHC(2 &BTNTEXT2)
A 03 PSHBTNCHC(3 &BTNTEXT3)
A X 2S 0P
A Y 2S 0P
A TITLE 20A P
A BTNTEXT1 14A P
A BTNTEXT2 14A P
A BTNTEXT3 14A P
A MSGLARGE 540A B 2 1CNTFLD(60)
A DSPATR(PR)
A 10 DSPATR(UL)
A R RLARGEW
A WINDOW(&Y &X 14 60)
A OVERLAY
A KEEP
A WDWTITLE((*TEXT &TITLE))
A RTNVAL 2Y 0B 12 3PSHBTNFLD(*RSTCSR (*NUMCOL 3) (*GUT-
A TER 4))
A CHCAVAIL((*COLOR GRN))
A CHCUNAVAIL((*DSPATR ND))
A 01 PSHBTNCHC(1 &BTNTEXT1)
A 02 PSHBTNCHC(2 &BTNTEXT2)
A 03 PSHBTNCHC(3 &BTNTEXT3)
A X 2S 0P
A Y 2S 0P
A TITLE 20A P
A BTNTEXT1 14A P
A BTNTEXT2 14A P
A BTNTEXT3 14A P
A MSGLARGE 540A B 2 1CNTFLD(060)
A WRDWRAP
A DSPATR(PR)
A 10 DSPATR(UL)
A*----------------------------------------------------------------
A* RASSUME to keep the background
A R RASSUME
A ASSUME
A 1 2' '

UPPER and lower case

Making a string uppper or lower case in ILE-RPG can be done with %XLATE, but needs a string with UPPER and a string with lower case characters. So why not make it in to a function…..

Source copymember
d uCase pr 2048a varying
d @string 2048a value varying
d @offset 4s 0 value options(*nopass)
d @lengte 4s 0 value options(*nopass)

d lCase pr 2048a varying
d @string 2048a value varying
d @offset 4s 0 value options(*nopass)
d @lengte 4s 0 value options(*nopass)

Source ILE-RPG

//********************************************************************************************
p uCase b export
//********************************************************************************************
// Make string uppercase
d pi 2048a varying
d @string 2048a value varying
d @offset 4s 0 value options(*nopass)
d @lengte 4s 0 value options(*nopass)

/free
select;

// 3 parameters
when %parms = 3 and @offset > 0 and @lengte > 0;
if (@offset + @lengte-1) >= %len(@string);
return %xlate(cLower:cUpper:left(@string:@offset+@lengte-1):@offset);
else;
return %xlate(cLower:cUpper:left(@string:@offset+@lengte-1):@offset)
+ mid(@string:@offset + @lengte);
endif;

// 2 parameters
when (%parms = 2 and @offset > 0) or
(%parms = 3 and @offset > 0 and @lengte = 0);
return %xlate(cLower:cUpper:@string:@offset);

// 1 parameter
other;
return %xlate(cLower:cUpper:@string);
endsl;
/end-free
p e

//********************************************************************************************
p lCase b export
//********************************************************************************************
// Make string lowercase
d pi 2048a varying
d @string 2048a value varying
d @offset 4s 0 value options(*nopass)
d @lengte 4s 0 value options(*nopass)

/free
select;

// 3 parameters
when %parms = 3 and @offset > 0 and @lengte > 0;
if (@offset + @lengte-1) >= %len(@string);
return %XLATE(cUpper:cLower:left(@string:@offset+@lengte-1):@offset);
else;
return %XLATE(cUpper:cLower:left(@string:@offset+@lengte-1):@offset)
+ mid(@string:@offset + @lengte);
endif;

// 2 parameters
when (%parms = 2 and @offset > 0) or
(%parms = 3 and @offset > 0 and @lengte = 0);
return %xlate(cUpper:cLower:@string:@offset);

// 1 parameter
other;
return %xlate(cUpper:cLower:@string);
endsl;
/end-free
p e

Immediate IF

One of the functions I miss in ILE-RPG is the Immediate IF. It can be very usefull for making your sourcecode shorter and more readable. But we have to make two versions, one for alfanumeric (cIif), the other for numeric (nIff) return values.

Example with ILE-RPG if:
if @sum > 0;
@value = "Debet";
else;
@value = "Credit";
endif;

Example with Iif:
@value = cIif(@sum>0:"Debet":'Credit");

Sourcecode copymember
     // Give alfanumeric value for TRUE and FALSE
     d cIIf            pr          2048a   varying
     d @condition                      n   value
     d @TrueValue                  2048a   value varying
     d @FalseValue                 2048a   value varying

     // Give numeric value for TRUE and FALSE
     d nIIf            pr            20s10
     d @condition                      n   value
     d @TrueValue                    63s32 value
     d @FalseValue                   63s32 value

Sourcecode ILE-RPG
      //************************************************************************
     p cIIf            b                   export
      //************************************************************************
      // Doet een immediate if  (voor char return values)
     d                 pi          2048a   varying

     d @condition                      n   value
     d @trueValue                  2048a   value varying
     d @falseValue                 2048a   value varying

      /free
       if @condition;
         return @trueValue;
       else;
         return @falseValue;
       endif;
      /end-free
     p                 e

      //************************************************************************
     p nIIf            b                   export
      //************************************************************************
      // Doet een immediate if  (voor num return values)
     d                 pi            20s10

     d @condition                      n   value
     d @trueValue                    20s10 value
     d @falseValue                   20s10 value
      /free
       if @condition;
         return @trueValue;
       else;
         return @falseValue;
       endif;
      /end-free
     p                 e