Set Color Procedure
Manipulate 5250 color using a display attribute field.
Set Color Procedure
This was written quite some time ago. A project called for a new field on a display required to be in a specific color. The problem was--all 99 conditioning indicators had already been used.After the project, it was added to a common service program so that it might be used in any application program. There are advantages to using this instead of indicators to change display field attributes. It doesn't require the DDS to change if the color attribute needs to change. The technique is much older than the code. The first time I wrote this, I had to use BITON and BITOFF to set the bit pattern to represent the color attributes.
H DEBUG(*YES)
H nomain
****************************************************************
* PROGRAM NAME - SC0062RM *
* *
* FUNCTION - This is a module designed to set the hex code *
* byte for display attributes *
* *
* PROGRAMMER - STEVE CROY 08/12/09 *
****************************************************************
****************************************************************
* MODIFICATION LOG *
* *
* DATE PROGRAMMER DESCRIPTION *
* *
****************************************************************
* Prototypes
*---
/copy qrpglesrc,SC0000_pr
*---
P SetColor B export
D SetColor PI 1A
D colorValue 3 CONST OPTIONS(*OMIT:*NOPASS)
D colorAttr 2 CONST OPTIONS(*NOPASS)
D fieldPr 2 CONST OPTIONS(*NOPASS)
D Up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D Lo C 'abcdefghijklmnopqrstuvwxyz'
*---
* Define constants
*---
D Blue C Const(X'3A')
D Green C Const(X'20')
D Pink C Const(X'38')
D Red C Const(X'28')
D Turquoise C Const(X'30')
D White C Const(X'22')
D Yellow C Const(X'32')
D Blink C CONST(X'2A')
D NonDisplay C CONST(X'27')
D Protect C Const(X'80')
D Reverse C Const(X'01')
D Underline C Const(X'04')
D color S 3A
D attr S 2A
D pr S 2A
D attribute S 1A
IF %parms < 1 or %addr(colorvalue) = *null ;
color = 'GRN' ;
ELSE ;
color = %xlate(lo: up: colorValue) ;
ENDIF ;
IF %parms < 2 ;
attr = ' ' ;
ELSE ;
attr = %xlate(lo: up: ColorAttr) ;
ENDIF ;
IF %parms > 2 ;
pr = 'PR' ;
ELSE ;
pr = *blank ;
ENDIF ;
SELECT ;
WHEN Color = 'BLU' ;
attribute = Blue ;
WHEN Color = 'PNK' ;
attribute = Pink ;
WHEN Color = 'RED' ;
attribute = Red ;
WHEN Color = 'TRQ' ;
attribute = Turquoise ;
WHEN Color = 'WHT' ;
attribute = White ;
WHEN Color = 'YLW' ;
attribute = Yellow ;
OTHER ;
attribute = Green ;
ENDSL ;
IF attr = 'UL' or attr = 'UR' ;
attribute = %bitOr(attribute:Underline) ;
ENDIF ;
IF attr = 'RI' or attr = 'UR' ;
attribute = %bitOr(attribute:Reverse) ;
ENDIF ;
IF attr = 'BL' ;
attribute = Blink ;
ENDIF ;
IF attr = 'ND' ;
attribute = NonDisplay ;
ENDIF ;
IF pr = 'PR' ;
attribute = %bitOr(attribute:Protect) ;
ENDIF ;
RETURN attribute ;
P SetColor E
Setting Color Attributes
The program below is bound to a service program that includes the SETCOLOR procedure. The DDS code is listed on this page. Note that in the initialization process the variable KEYFLDS is set to blue. The command key line on the display will appear in blue because of the value of the P-field.
H DEBUG(*YES)
H OPTION(*SRCSTMT : *NODEBUGIO) DFTACTGRP(*NO) ACTGRP('QILE')
H BNDDIR('SC0000_BD')
********************************************************************
* Program Name - SC0195RP *
* *
* Function - This program was designed to display softcode *
* user maintenance. This display is a pop-up *
* window with fields protected in the view mode. *
* *
* Programmer - Steve Croy 10/19/06 *
********************************************************************
********************************************************************
* PROGRAM INTERFACE SECTION *
* *
* CALLED BY PROGRAMS: *
* CALLS PROGRAMS....: *
* *
********************************************************************
FSC0195DF CF E WORKSTN
F INFDS(DSPDS)
D USERPR E DS extname(SCUSRSPF)
D FunctionKey E DS EXTNAME(SCKEYSPF) qualified Function keys
D PGMDS ESDS EXTNAME(SCPSTSPF) Pgm status map
D DSPDS E DS EXTNAME(SCDSPFPF) Display INFDS
D MACDS E DS EXTNAME(SCFUNCPF) INZ Key map
D OPTDS E DS EXTNAME(SCOPTNPF) INZ Option map
D FUNCT E DS EXTNAME(SCMACRPF) INZ Macro map
*
D hostent DS Based(p_hostent)
D h_name *
D h_aliases *
D h_addrtype 10I 0
D h_length 10I 0
D h_addr_list *
*
D DS
D DEC 4B 0
D BIN 1 OVERLAY(DEC:2)
*----------------------------------------------------------------
/copy qrpglesrc,SC0000_pr
D gethostbyname PR * ExtProc('gethostbyname')
D HostName * Value Options(*String)
*----------------------------------------------------------------
* Define indicators
*----------------------------------------------------------------
d indPtr s * inz( %addr(*in) )
* define named indicators
d indicators ds 99 based( indPtr )
d ScreenChange n overlay( indicators : 22 )
D DFTPOS DS INZ
D DFROW 2 0 INZ(4)
D DFCOL 3 0 INZ(20)
*---------------------------------------------------------------------
* Start of work fields
*---------------------------------------------------------------------
D @at S 3p 0
D attr S 1
D AUTHL S 3 inz('999')
D AddMode S n
D ChangeMode S n
D CMDKEY S 720
D DeleteMode S n
D Domain_name S 90A Inz
D ErrIndicated S n
D FKEYDS S 1
D l S 3p 0
D M S 3S 0
D MessageString S 255a
D Messagetitle S 27a inz('Error SC0195RP Message')
D NoErrorFound S n
D p_hostent S *
D ReturnRequested...
D S n
D ViewMode S n
*---------------------------------------------------------------------
* END of work fields
*---------------------------------------------------------------------
D SC0195RP PR
D p$user 10
D p$mode 1
D SC0195RP PI
D p$user 10
D p$mode 1
/free
//*---------------------------------------------------------------
//* Display Screen, test for EOJ, check for functions detected
//*---------------------------------------------------------------
DOU ReturnRequested ;
EXFMT SC019502 ;
EXSR @SVCSR ;
//*------------------------------------------------------------
//* Determine what action to perform; get key function
//*------------------------------------------------------------
ReturnRequested = *off ;
EXSR @EditKeyPressed ;
SELECT ;
WHEN funct = 'EXIT' ;
EXSR @Exit ;
WHEN funct = 'ADDRECORD' ;
EXSR @AddMode ;
WHEN funct = 'DLTRECORD' ;
EXSR @DeleteMode ;
WHEN funct = 'DSPRECORD' ;
EXSR @ViewMode ;
WHEN funct = 'CHGRECORD' ;
EXSR @ChangeMode ;
WHEN funct = 'DELETE' ;
EXSR @DeleteRecord ;
WHEN funct = 'ACTIVATE' and msstat = '0' ;
ActivateUser(p$user) ;
ReturnRequested = *on ;
WHEN funct = 'EXPIRE' and msstat = '1' ;
ExpireUser(p$user) ;
ReturnRequested = *on ;
WHEN funct = 'ENTER' and not ViewMode and not DeleteMode ;
EXSR @ENTER ;
WHEN funct = 'ENTER' and ViewMode ;
ReturnRequested = *on ;
ENDSL ;
funct = *blank ;
EXSR @GetCmdKeys ;
ENDDO ;
EXSR @Exit ;
//*================================================================
//* Subroutine to save cursor position
//*================================================================
BEGSR @SVCSR;
DEC = 0;
EVALR BIN = ROW;
#ROW = DEC - 4;
DEC = 0;
EVALR BIN = COL;
#COL = DEC - 10;
ENDSR;
//*================================================================
//* Initialize data variables and mode
//*================================================================
BEGSR *INZSR;
FunctionKey = FunctionKeys();
z$usrp = p$user;
WRITE SC019500;
WRITE SC019501;
keycolor = SetColor('blu');
IF UserFound(p$user);
USERPR = GetUserData();
ELSE;
CLEAR USERPR;
p$mode = 'A';
ENDIF;
EXSR @MoveData;
SELECT;
WHEN p$mode = 'A';
EXSR @AddMode;
WHEN p$mode = 'C';
EXSR @ChangeMode;
WHEN p$mode = 'D';
EXSR @DeleteMode;
OTHER;
EXSR @ViewMode;
ENDSL;
EXSR @GetCmdKeys;
ENDSR;
//*================================================================
//* Subroutine to process enter key operations
//*================================================================
BEGSR @Enter ;
ErrIndicated = *off ;
NoErrorFound = *on ;
IF ScreenChange ;
EXSR @MoveScreen ;
EXSR @validate ;
IF ChangeMode ;
NoErrorFound = UpdateUser() ;
IF NoErrorFound ;
attr = setColor('WHT') ;
z$msg1 = attr + 'Record updated.' ;
ELSE ;
attr = setColor('RED') ;
z$msg1 = attr + 'Record not updated.' ;
ENDIF ;
ELSE ;
NoErrorFound = InsertUser() ;
IF NoErrorFound ;
attr = setColor('WHT') ;
z$msg1 = attr + 'Record added.' ;
EXSR @AddMode ;
ELSE ;
attr = setColor('RED') ;
z$msg1 = attr + 'Record not added.' ;
ENDIF ;
ENDIF ;
ENDIF ;
IF ChangeMode and not ScreenChange and NoErrorFound ;
ReturnRequested = *on ;
ENDIF ;
ENDSR ;
//*================================================================
//* Subroutine to validate domain name
//*================================================================
BEGSR @Validate ;
@at = %scan('@':z$mail:1) ;
l = %len(z$mail) ;
IF @at = 0 ;
%subst(z$mail:l) = '*' ;
ELSE ;
Domain_name =%Subst(z$mail:@at + 1) ;
p_hostEnt = gethostbyname(%trim(Domain_Name)) ;
IF p_hostEnt = *null ;
%subst(z$mail:l) = '*' ;
ENDIF ;
ENDIF ;
ENDSR ;
//*================================================================
//* Subroutine to process record delete
//*================================================================
BEGSR @DeleteRecord ;
NoErrorFound = DeleteUser() ;
IF NoErrorFound ;
ReturnRequested = *on ;
ELSE ;
MessageString ='Unable to delete record' ;
DisplayMessage(MessageString:messagetitle) ;
ENDIF ;
ENDSR ;
//*================================================================
//* SET FIELDS FOR RECORD ADD
//*================================================================
BEGSR @AddMode ;
z$mode = 'Add' ;
usrflds = SetColor('GRN':'UL') ;
chgflds = SetColor('GRN':'UL') ;
z$edte = dateToday() ;
z$xdte = 99999999 ;
z$usrp = *blanks ;
z$mail = *blanks ;
z$susr = *blanks ;
ChangeMode = *OFF ;
DeleteMode = *off ;
ViewMode = *off ;
AddMode = *ON ;
#ROW = dfrow - 1 ;
#COL = dfcol ;
ENDSR ;
//*================================================================
//* SET FIELDS FOR RECORD CHANGE
//*================================================================
BEGSR @ChangeMode ;
z$mode = 'Change' ;
usrflds = SetColor('WHT':'NL':'PR') ;
chgflds = SetColor('TRQ':'UL') ;
ChangeMode = *ON ;
AddMode = *off ;
DeleteMode = *off ;
ViewMode = *off ;
#ROW = dfrow ;
#COL = dfcol ;
ENDSR ;
//*================================================================
//* SET FIELDS FOR RECORD Delete
//*================================================================
BEGSR @DeleteMode ;
z$mode = 'Delete' ;
usrflds = SetColor('RED':'NL':'PR') ;
chgflds = SetColor('RED':'NL':'PR') ;
attr = SetColor('RED':'BL') ;
z$msg1 = attr + 'Use function key to delete record.' ;
DeleteMode = *ON ;
AddMode = *off ;
ChangeMode = *off ;
ViewMode = *off ;
ENDSR ;
//*===============================================================
// * SET FIELDS FOR RECORD View
//*===============================================================
BEGSR @ViewMode ;
z$mode = 'View' ;
usrflds = SetColor('YLW':'NL':'PR') ;
chgflds = SetColor('YLW':'NL':'PR') ;
ViewMode = *on ;
AddMode = *off ;
DeleteMode = *off ;
ChangeMode = *off ;
ENDSR ;
//*===============================================================
//* Move data to screen fields
//*===============================================================
BEGSR @MoveData ;
z$usrp = msusrp ;
z$susr = mssusr ;
z$edte = msedte ;
z$xdte = msxdte ;
z$mail = msmail ;
ENDSR ;
//*===============================================================
//* Move Screen fields to database file
//*===============================================================
BEGSR @MoveScreen ;
setUserName(z$usrp) ;
setSubstitute(z$susr) ;
setUserXdte(z$xdte) ;
setUserEdte(z$edte) ;
setUserEmail(z$mail) ;
ENDSR ;
//*================================================================
//* Subroutine to edit command key functions
//* The program name, panel ID and the key are used to retreive the
//* function macro. If the call fails, default to EXIT.
//*================================================================
BEGSR @EditKeyPressed ;
fkeyds = KeyPressed ;
funct = *BLANKS ;
fpgmid = PRGNAM ;
fpnlid = UpperCase(z$mode:%size(z$mode)) ;
fmacro = *BLANKS ;
MONITOR ;
GetFunction(fpgmid:fpnlid:fkeyds:fkeyid:fmacro:authl) ;
ON-ERROR ;
MessageString ='Error occurred editing function key' ;
DisplayMessage(MessageString:messagetitle) ;
ENDMON ;
FUNCT = FMACRO ;
ENDSR ;
//*=================================================================
// * Subroutine to Get the command keys for the application
//*=================================================================
BEGSR @GetCmdKeys;
fpgmid = PRGNAM;
fpnlid = UpperCase(z$mode:%size(z$mode)) ;
CMDKEY = *BLANKS;
MONITOR;
GetKeyText(fpgmid:fpnlid:cmdkey:authl);
ON-ERROR;
MessageString ='Error occurred getting keys' ;
DisplayMessage(MessageString:messagetitle) ;
ENDMON;
m=0;
DisplayKeys(cmdkey: z$key1: z$key2: M);
ENDSR;
//*==================================================================
//* PROCESS END OF REQUEST
//*==================================================================
BEGSR @EXIT;
*INLR = *ON;
RETURN;
ENDSR;
Note that in other subroutines the color values vary. In the delete mode, the screen fields will display in red.
In the add mode, all of the fields will be green and underlined. In the change mode, the KEYFLDS will be displayed
in white (HI) and are protected from change, while the fields that can be changed (CHGFLDS) will be underlined in turquoise.
If the program was launched in view mode, the fields will be in will be displayed in yellow and will be protectede (PR)--no changes
are allowed. By judicious use of the P-fields and the SETCOLOR service, the same display panel may be used for VIEW, CHANGE, DELETE,
and ADD, without resorting to indicators.