RE: Show SQL running total in RPG

Hi

I use this method, cannot remember where I saw it first, but I use it on
our applications all the time. Apologies for mixing the different styles,
had to copy it from different copybooks. Will show progress bar at bottom
of screen.

F3=Exit F4=Prompt F9=Retrieve F12=Cancel
F23=Set initial menu
Processing Record - Step 12613 of 44693 - 28%.


dcl-ds Datastructure1;
FileName char(128);
LibName char(128);
FileType char(1);
End-ds;
*================================================================
dcl-s wCurStep uns(10) inz(0);
dcl-s wMaxStep uns(10) inz(0);
dcl-s wRecCount uns(10) inz(0);
dcl-s SqlString char(1000);
dcl-c Col_Green CONST(X'21');
dcl-c Col_White CONST(X'23');
dcl-c Col_Red CONST(X'29');
dcl-c Col_Turqoise CONST(X'31');
dcl-c Col_Yellow CONST(X'33');

dcl-c Col_Pink CONST(X'39');

dcl-c Col_Blue CONST(X'3B');


*====================================================================*

D APIErrorDS DS

D A1_ByteProv 10I 0
Bytes Provided
D A1_ByteAv 10I 0
Bytes Available
D A1_MsgId 7
Error-Id
D A1_Reserv 1
Reserved
D A1_ExeptD 256
Exeption Data
D pMsgKey S 4A inz(*Blanks)


*====================================================================*

D SndPgmMsg PR ExtPgm('QMHSNDPM')

D p_MsgID 7A const
Message-Id
D p_FileLib 20A const
Message-Lib/File
D p_MsgData 1024A const options(*VarSize)
Var.Message-Texts
D p_LenMsgD 10I 0 const
Length Var.Msg-Texts
D p_MsgType 10 const
Message-Lib/File
D p_StackEntry 10 const
Call Stack Entry
D p_StackCount 10I 0 const
Call Stack Counter
D p_MsgKey 4 const
Message-Key
D p_APIError like(APIErrorDS)
Error
D p_LenStackE 10I 0 const options(*NoPass)

D p_StackQual 20 const options(*NoPass)
Call Stack Entry Qua
D p_DspWait 10I 0 const options(*NoPass)
Display Wait Time
D p_StackType 10 const options(*NoPass)
Call Stack Entry Dat
D p_CharSetI 10I 0 const options(*NoPass)
Coded Char. Set Iden



*====================================================================*

* sleep(x) will DLYW the job for pDurantion microseconds.

D usleep Pr ExtProc('usleep')

D pDuration 10U 0 Value


*====================================================================*



SqlString =

'SELECT TABLE_NAME, TABLE_SCHEMA, FILE_TYPE FROM systables';

Exec SQL Prepare SQLgetA From :SQLstring;

// A - Open Cursor as "insensitive"

Exec SQL Declare INTCURSORA insensitive Cursor For SQLgetA;

Exec SQL Open IntCursorA;

// See how many records are in the cursor

exec sql get diagnostics :wRecCount = DB2_NUMBER_ROWS;

// Allocate record count to the many steps that needs to be taken

wMaxStep += wRecCount;



If wRecCount > 0;

Dou SqlCod > 0;

Exec Sql Fetch Next from IntCursorA into :DataStructure1;

If SQLCOD = 0;

SndMessage('Processing Record');

/// ----> Process record here....

usleep(30);

Endif;

Enddo;

EndIF;

Exec SQL Close IntCursorA;

*Inlr = *ON;

Return;

// ================================================================

// SndMessage Procedure

// ================================================================

dcl-proc SndMessage export;

dcl-pi *n;

pMsg char(50) value;

end-pi;

SndProgressMsg(wCurStep:wMaxStep:%trim(pMsg):COL_RED);

wCurStep += 1;

end-proc;

// ================================================================

// SndProgressMsg Procedure

// ================================================================

dcl-proc SndProgressMsg export;

dcl-pi SndProgressMsg char(20);

pStartVal uns(10) value;

pEndVal uns(10) value;

pShortMsg char(50) value;

pDspChar char(1) value;

pStartTime timestamp value options(*nopass);

end-pi;

dcl-s pMsg char(80) inz(*blanks);

dcl-s pMsgProgress char(80) inz(*blanks);

dcl-s pTempMsg char(80) inz(*blanks);

dcl-s ProgressNbr uns(10) inz(0);

dcl-s ProgressPos uns(10) inz(0);

dcl-s WorkLen uns(3) inz(0);

dcl-s WorkColor char(1);

dcl-s ProgressLen uns(3) inz(0);

dcl-s TimeHMS time(*HMS) inz;

dcl-s TotalSecs zoned(9:0);

dcl-s CurrentTime timestamp;

dcl-s TempTime char(26);

// Check the input values first. The endvalue may not be 0 (zero)

WorkColor = COL_WHITE; // Default color for the line

If pEndVal = 0;

return 'DIVIDE BY 0';

endIf;

// If the Start Value is greater than the end-value, exit also.

If pStartVal > pEndVal;

return 'STARTVAL > ENDVAL';

endIf;

// Determine the % Value.

If pStartVal < pEndVal;

ProgressNbr = ((pStartVal/pEndVal)*100);

Else;

ProgressNbr = 100;

EndIf;

If ProgressNbr = 0;

ProgressNbr = 1;

EndIf;

If %Parms >= 5;

TempTime = ' ';

Else;

TempTime = ' ';

EndIf;

// Buildup the message

pMsgProgress = *ALL'.';

pTempMsg = *Blanks;

If pDspChar = WorkColor;

select;

When pDspChar = COL_WHITE;

WorkColor = COL_RED;

Other;

WorkColor = COL_WHITE;

EndSl;

Endif;

pMsg = pDspChar + %trim(pShortMsg) + ' - Step '
+
%trim(%editc(pStartVal:'Z')) + ' of '
+
%trim(%editc(pEndVal:'Z')) + ' - '
+
%trim(%editc(ProgressNbr:'Z')) + '%';

%subst(pMsg:54:26) = TempTime;

ProgressPos = 78 * ProgressNbr / 100;

If ProgressPos = 0;

ProgressPos = 1;

EndIf;

%subst(pMsg:ProgressPos:1) = WorkColor;

//

SndStsMsg(pMsg);

Return 'OK';

//

end-proc;



*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

* Procedure Name: SndStsMsg

*

* Description: Send a Status Message

*

* EXAMPLE:

C* callp SndEcsMsg('XCOM TransferId TfrNbr')

P SndStsMsg B Export

D SndStsMsg PI

D pMsg 1024A value

*

C callp SndPgmMsg('CPF9898'

C :'QCPFMSG *LIBL '

C :%trim(pMsg)

C :%len(%trim(pMsg))

C :'*STATUS'

C :'*EXT'

C :2

C :pMsgKey

C :ApiErrorDS)

P SndStsMsg E



Hope this helps.

Pieter