*:********************************************************************* *: *: Procedure file: ERRORSYS.PRG, Version 1.0 *: *: Author: Manuel Santos (IntelWare Systems) *: Copyright (c) 1990, IntelWare Systems *: Last modified: Jan/10/91 *: *: Procs & Fncts: ERRORSYS() *: : ERRORHDL() *: : MSGBOX() *: : PRT_SCRN() *: *:********************************************************************* * * *) Description: Runtime error system to replace Nantucket's ERRORSYS.PRG *) - For Clipper 5.0, v1.03! - will not work with S'87 *) or earlier. *) - This error handler pops up a formatted window detailing *) the nature of the error, and then requests a response from *) the user. I find this to be imperative, because a user *) is seldom able to give a description that is sufficiently *) detailed to accurately diagnose the problem. With this *) system, the user is given the option of printing the *) detailed error message, which also includes a copy of *) the users's screen at the time of the error (on the *) same page). *) - all network related errors are not affected and should *) therefore be handled locally as usual. Printing errors are *) tapped and the user is given the choice to abort the *) print statement and allow program execution to continue *) normally. As well, the current version does not generate *) an error on a divide by zero operation, but in case this *) is corrected in later releases, provisions have bee made *) to return 0 and continue program execution. *) - I had originally developed a similar error recovery *) system that I included with every application that I *) developed, but found (much to my dismay) that all previous *) error handlers no longer work with Clipper 5.0. *) *) => this error system is completely self sufficient, without requiring *) any additional externals. *) * Parameters passed by Clipper to error function: * err - error object * * NOTES: * - For a printing error to recover properly if the user chooses to cancel * the printout, all printing statements for that section of code must * be enclosed within BEGIN SEQUENCE...END SEQUENCE. * - The error message will be displayed on a pop-up window requesting a * response from the user. If the error is fatal, then the user is given * the option to generate a printout of the error. * - If you have a local error handler for a section of code, be sure to * re-enable this error block as soon as the local handler is no longer * required. This process is demonstrated on page 6-4 of the Clipper * Reference Manual. * - Clipper 5 directly supports setting of maximum screen columns and * lines. By default, the error message box will be centered within * whatever the screen size happens to be. If your programs do not use * the default 80x25 screen size, this may mean that the entire message may * not print correctly on laser printers. If this is the case, you may select * the message box to be located in the upper or lower left side of the * screen by declaring a PRIVATE variable called BoxPos and ititializing it * with either "UL" or "LL" before calling MsgBox() * - The MsgBox function can also be used as a general purpose popup * message function. Please see the function header for usage details. * The function also beeps when a message is displayed. If you wish to * change this, then alter the TONE function calls near the end of MsgBox(). * - Clipper is a registered trademark of Nantucket Corporation. * * ** Please see the enclosed documentation for licencing information, and * HAPPY CLIPPERing! * * * Compile with: CLIPPER clip5err /m/n * *********************************************************************** #include "error.ch" #include "set.ch" #include "setcurs.ch" #command RETRY => RETURN (.T.) #command RESUME => RETURN (.F.) *!********************************************************************* *! *! Procedure: ERRORSYS() *! *! Calls: ERRORBLOCK() *! *!********************************************************************* PROCEDURE ErrorSys() * * Note: this function automatically executes once at startup * ErrorBlock( {|e| ErrorHdl(e)} ) * return *!********************************************************************* *! *! Function: ERRORHDL() *! *! Calls: *! *!********************************************************************* STATIC FUNCTION ErrorHdl(err) * local ConsoleDevice, PrtStatus, ConsoleStatus local i, op local k_na := "N/A ", k_caller := (space(8) + "Called By: ") local k_calline := " Line: " local err_name[39] private MsgTitle, MsgArray := {}, UsrPrompt, UserResp:="" && must not be LOCAL! private rest_scrn, MsgBoxScrn && must not be LOCAL - used in MsgBox() // Generic error codes - from the standard "error.ch" file err_name[EG_ARG] := "EG_ARG" err_name[EG_BOUND] := "EG_BOUND" err_name[EG_STROVERFLOW] := "EG_STROVERFLOW" err_name[EG_NUMOVERFLOW] := "EG_NUMOVERFLOW" err_name[EG_ZERODIV] := "EG_ZERODIV" err_name[EG_NUMERR] := "EG_NUMERR" err_name[EG_SYNTAX] := "EG_SYNTAX" err_name[EG_COMPLEXITY] := "EG_COMPLEXITY" err_name[EG_MEM] := "EG_MEM" err_name[EG_NOFUNC] := "EG_NOFUNC" err_name[EG_NOMETHOD] := "EG_NOMETHOD" err_name[EG_NOVAR] := "EG_NOVAR" err_name[EG_NOALIAS] := "EG_NOALIAS" err_name[EG_CREATE] := "EG_CREATE" err_name[EG_OPEN] := "EG_OPEN" err_name[EG_CLOSE] := "EG_CLOSE" err_name[EG_READ] := "EG_READ" err_name[EG_WRITE] := "EG_WRITE" err_name[EG_PRINT] := "EG_PRINT" err_name[EG_UNSUPPORTED] := "EG_UNSUPPORTED" err_name[EG_LIMIT] := "EG_LIMIT" err_name[EG_CORRUPTION] := "EG_CORRUPTION" err_name[EG_DATATYPE] := "EG_DATATYPE" err_name[EG_DATAWIDTH] := "EG_DATAWIDTH" err_name[EG_NOTABLE] := "EG_NOTABLE" err_name[EG_NOORDER] := "EG_NOORDER" err_name[EG_SHARED] := "EG_SHARED" err_name[EG_UNLOCKED] := "EG_UNLOCKED" err_name[EG_READONLY] := "EG_READONLY" * * Save current output devices ConsoleDevice := set(_SET_DEVICE) PrtStatus := set(_SET_PRINTER) ConsoleStatus := set(_SET_CONSOLE) * * Make sure output is to screen SET DEVICE TO SCREEN SET PRINT OFF SET CONSOLE ON // process the errors do case case ( err:genCode == EG_ZERODIV .and. err:canRetry ) // currently, x/0 returns 0 and does not generate an error, however, // * just in case Nantucket fixes this in future releases... return (0) case ( err:genCode == EG_OPEN .and. err:canDefault ) if NetErr() // network errors are handled locally // set(_SET_DEVICE, ConsoleDevice) set(_SET_PRINTER, PrtStatus) set(_SET_CONSOLE, ConsoleStatus) RESUME //return (.f.) to select driver default error recovery else asize(MsgArray, 19) MsgTitle := "Error " + ltrim(str(err:gencode)) + ":" + ; err_name[err:gencode] MsgArray[1] := "An Open Error has occured. Some causes of this are:" MsgArray[2] := "" MsgArray[3] := " ù A disk drive door is open," MsgArray[4] := " ù A diskette is not in place," MsgArray[5] := " ù Current drive is no longer available," MsgArray[6] := " ù The file is not present in the default directory." MsgArray[7] := "" MsgArray[8] := "The error occurred while attempting to:" op := err:operation + " " + err:filename MsgArray[9] := " Descr.: " + iif(!empty(err:description()), err:description(), k_na) + ; " For: " + iif(!empty(op), op, k_na) MsgArray[10] := " Within SubSystem: " + iif(!empty(err:subsystem()), err:subsystem(), k_na) + ; ", Code: " + iif(!empty(err:subcode()), ltrim(str(err:subcode())), k_na) MsgArray[11] := " (DOS error Code of: " + ltrim(str(err:oscode)) + ")" MsgArray[12] := "" MsgArray[13] := "Error Occurred at: " + padr(procname(2)+",", 14) + ; k_calline + ltrim(str(procline(2))) MsgArray[14] := "" MsgArray[15] := "" if !empty(procname(3)) MsgArray[14] := k_caller + padr(procname(3)+",", 14) + k_calline + ; ltrim(str(procline(3))) endif if !empty(procname(4)) MsgArray[15] := k_caller + padr(procname(4)+",", 14) + k_calline + ; ltrim(str(procline(4))) endif MsgArray[16] := "If the problem can be corrected, please do so and" MsgArray[17] := "press R (Retry). Otherwise, this program cannot" MsgArray[18] := "continue - please obtain a printout of" MsgArray[19] := "this screen to help with problem diagnosis." UsrPrompt := "Retry, Print Screen and Quit, Quit (R/P/Q)" * MsgBox() * do case case UserResp == "R" * Retry the operation - reset output devices first set(_SET_DEVICE, ConsoleDevice) set(_SET_PRINTER, PrtStatus) set(_SET_CONSOLE, ConsoleStatus) RETRY //return (.t.) to retry operation that triggered error case UserResp == "P" * Print the error message, then quit. * re-generate the error message first UsrPrompt := "Runtime Error - Open" UserResp := space(1) rest_scrn := .F. MsgBoxScrn := space(1) KEYBOARD CHR(13) && stuff an Enter to return from MsgBox MsgBox() RELEASE MsgTitle, rest_scrn, UsrPrompt, MsgArray, RespArray * now print the error PRT_SCRN() && print the MsgBox screen restore screen from MsgBoxScrn PRT_SCRN() && print screen of prg @ point of error set print on ?? chr(12) // eject set print off endcase endif * case (err:gencode == EG_PRINT .and. err:canretry) * printer error handling asize(MsgArray, 15) MsgTitle := "Error " + ltrim(str(err:gencode)) + ":" + ; err_name[err:gencode] MsgArray[1] := "The printer is not responding. The following" MsgArray[2] := "are possible causes of this problem:" MsgArray[3] := "" MsgArray[4] := " ù The print device is not available on this system," MsgArray[5] := " ù the printer is powered off," MsgArray[6] := " ù it is out of paper," MsgArray[7] := " ù the Online or Select light is not on," MsgArray[8] := " ù the cable is disconnected at the printer" MsgArray[9] := " or the computer." MsgArray[10] := "" MsgArray[11] := "Error Occurred at: " + padr(procname(2)+",", 14) + ; k_calline + ltrim(str(procline(2))) MsgArray[12] := "" MsgArray[13] := "" if !empty(procname(3)) MsgArray[12] := k_caller + padr(procname(3)+",", 14) + k_calline + ; ltrim(str(procline(3))) endif if !empty(procname(4)) MsgArray[13] := k_caller + padr(procname(4)+",", 14) + k_calline + ; ltrim(str(procline(4))) endif MsgArray[14] := "If you can correct the problem, please do so. Otherwise" MsgArray[15] := "the printout will be aborted." UsrPrompt := "Retry Printout (Y/N)" * MsgBox() * set(_SET_DEVICE, ConsoleDevice) set(_SET_PRINTER, PrtStatus) set(_SET_CONSOLE, ConsoleStatus) if UserResp == "Y" err:cargo := .t. // can be used by the calling program RETRY //return (.t.) else err:cargo := .f. // can be used by the calling program BREAK err // offending program resumes after END SEQUENCE statement. endif * otherwise * all other errors asize(MsgArray, 15) MsgTitle := "Error " + ltrim(str(err:gencode)) + ":" + ; err_name[err:gencode] MsgArray[1] := "An error has occured while running this program." MsgArray[2] := "Following is information that will be required to" MsgArray[3] := "assist with correcting this problem:" MsgArray[4] := "" op := err:operation + " " + err:filename MsgArray[5] := " Description: " + iif(!empty(err:description()), err:description(), k_na) + ; " For: " + iif(!empty(op), op, k_na) MsgArray[6] := "" MsgArray[7] := " Within SubSystem: " + iif(!empty(err:subsystem()), err:subsystem(), k_na) + ; ", Code: " + iif(!empty(err:subcode()), ltrim(str(err:subcode())), k_na) MsgArray[8] := " (DOS error Code of: " + ltrim(str(err:oscode)) + ")" MsgArray[9] := "" MsgArray[10] := "Error Occurred at: " + padr(procname(2)+",", 14) + ; k_calline + ltrim(str(procline(2))) MsgArray[11] := "" MsgArray[12] := "" if !empty(procname(3)) MsgArray[11] := k_caller + padr(procname(3)+",", 14) + k_calline + ; ltrim(str(procline(3))) endif if !empty(procname(4)) MsgArray[12] := k_caller + padr(procname(4)+",", 14) + k_calline + ; ltrim(str(procline(4))) endif MsgArray[13] := " ===> This program cannot continue. <===" MsgArray[14] := "Please see your contact person regarding this" MsgArray[15] := "problem." UsrPrompt := "Print Screen for Programmer (Y/N)" * MsgBox() * if UserResp == "Y" * print the screen * regen the message first, then print the screen UsrPrompt := "Runtime Error - Misc." UserResp := space(1) rest_scrn := .F. MsgBoxScrn := space(1) KEYBOARD CHR(13) && stuff an Enter to return from MsgBox MsgBox() RELEASE MsgTitle, rest_scrn, UsrPrompt, MsgArray, RespArray * now print the error PRT_SCRN() && print the MsgBox screen restore screen from MsgBoxScrn PRT_SCRN() && print screen of prg @ point of error set print on ?? chr(12) // eject set print off endif endcase * ERRORLEVEL(1) QUIT return { .f. } *!********************************************************************* *! *! Function: MSGBOX() *! *! Called by: ERRORHDL() (function in ERRORSYS.PRG) *! *!********************************************************************* STATIC FUNCTION MsgBox * *) A Multipurpose function that displays a multi-line message in a screen *) box & then waits for a validated response from the user. *) - used here by the ERRORSYStem, but can be used anywhere else. * - All message lines need not be the same size. The widest message * is found to determine the size of the window. * - valid user responses are extracted from the user prompt message * ie: "Retry or Abort (R/A)" would allow R or A as a response. * ^^^^^ * * * ==> Syntax: * MsgBox() * - because the function was designed to be flexible, there * are many parameters that would need to be passed. As an * alternate approach, the required variables should be defined * and initialized by the calling routine, and NO parameters * are passed as arguments. These values are then inherited by * MsgBox(). Where the variables do not exist, default values * are used. The minimum requirement is to create and initialize * a message array (MsgArray) before calling MsgBox(). * * * Public/Inherited variables * MsgTitle C title to display on 1st line of the box - * - default is "ATTENTION:" * MsgArray[] C array containing message lines. * UsrPrompt C User Prompt to display on bottom line of box * - default = "Press Any Key to Continue" * UserResp C user response response returned to calling prg * clr_frame C color for box frame -} * clr_title C color for title } * clr_text C color for messages (text) }defaults used if not suppl. * clr_instr C color for UsrPrompt } * clr_shadow C color for shadow -} * MsgBoxScrn C screen saved prior to calling MsgBox * * frame N 0 = no characters in border * 1 = single line box * 2 = double line box * 3 = double line top/bottom, single line sides * 4 = single line top/bottom, double line sides * C custom frame characters with eight characters as * in the @...BOX command * - default = 1 (single line box * BoxPos C UR = upper right corner of screen * UL = upper left corner of screen * LL = lower left corner of screen * LR = lower right corner of screen * C = center of screen * - default = C * lexplode L .T. = exploding box * .F. = no explosion * - default = .T. * limplode L .T. = implode screen before restore * .F. = no implosion * - defaults to explode value if not supplied * DrawShadw L .T. = shadow * .F. = no shadow * - default = .T. * ShadwChar C character to use for shadow * - default = CHR(176) "°" * ShadwSide C L = shadow on left side of box * R = shadow on right side of box * - default = R * rest_scrn L .T. = restore screen upon RETURN to calling prg * .F. = screen not restored * - default = .T. * * MsgBox calling example - custom * * DECLARE MsgArray[2] * MsgArray[1] = "Printer is not ready. Make sure" * MsgArray[2] = "it is on-line and has paper." * UserResp = space(1) * errtitle = "Printer Not Ready" * frame = 1 * UsrPrompt = "Retry or Abort (R/A)" * BoxPos = "UL" * rest_scrn = .t. * lexplode = .t. * limplode = .t. * DrawShadw = .t. * ShadwChar = "±" * ShadwSide = 'R' * MsgBox() * RELEASE MsgArray * * ÚÄÄÄÄÄÄ{ Printer Not Ready }ÄÄÄÄÄÄ¿ * ³ ³±± * ³ Printer is not ready. Make sure ³±± * ³ it is on-line and has paper. ³±± * ³ ³±± * ÀÄÄÄÄÄ{ Retry or Abort (R/A) {ÄÄÄÄÙ±± * ±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±± * * * * MsgBox calling example - default * DECLARE MsgArray[2] * MsgArray[1] = "The query string has become" * MsgArray[2] = "too long/complex." * MsgBox() * RELEASE MsgArray * * ÚÄÄÄÄÄÄÄÄ{ ATTENTION: }ÄÄÄÄÄÄÄ¿ * ³ ³ * ³ The query string has become ³ * ³ too long/complex. ³ * ³ ³ * À} Press Any Key to Continue {Ù * * * * MEMVAR MsgArray, UsrPrompt, UserResp, clr_frame, clr_title, clr_text MEMVAR clr_instr, clr_shadow, MsgBoxScrn, frame, box_pos, lexplode, limplode MEMVAR DrawShadw, ShadwChar, ShadwSide, rest_scrn LOCAL lframe, box_len, lTop, lLeft, lBottom, lRight LOCAL No_Msgs, msg_len, lcol_pos, ScrnMargn LOCAL lexp_top, lexp_left, lexp_bott, lexp_right, Tot_Exp LOCAL lcurr_color, lcurr_row, lcurr_col, CursorOn, X, Resp_Ok, action LOCAL llim_top, llim_left, llim_bott, llim_right, lpoint, rpoint LOCAL ValidResp, Counter * make sure some messages are defined. if len(MsgArray) == 0 * no messages....outta here! RETURN { .f. } endif * Process Parameter validation & assign defaults if type("MsgTitle") == "U" MsgTitle := "ATTENTION:" endif (type("MsgTitle") == "U") if type("UsrPrompt") == "U" UsrPrompt := "Press Any Key to Continue" Resp_Ok := .F. endif (type("UsrPrompt") == "U") if type("FRAME") == "U" FRAME := 1 endif (type("FRAME") == "U") box_pos := iif(!(type("BoxPos")=="C"), "C", upper(BoxPos)) if !(type("rest_scrn") == "L") rest_scrn := .T. endif (!(type("rest_scrn") == "L")) if !(type("lexplode") == "L") lexplode := .T. endif (!(type("lexplode") == "L")) limplode := lexplode if !(type("DrawShadw") == "L") DrawShadw := .T. endif (!(type("DrawShadw") == "L")) if type("ShadwChar") == "U" ShadwChar := CHR(176) endif (type("ShadwChar") == "U") ShadwSide := iif(!(type("ShadwSide")=="C"), "R", upper(ShadwSide)) * * * Check other memvars assigned by calling prg & assign defaults if needed * - first check the user prompt to extract valid responses. ValidResp := "" action := at('(', UsrPrompt) + 1 do while (action > 1) x := substr(UsrPrompt, action, 1) if (x == ")") .or. empty(x) action = 0 else ValidResp := ValidResp + x action := action+2 endif enddo ValidResp := upper(ValidResp) * * see if we need to verify that the user enters a correct response Resp_Ok := iif(empty(ValidResp), .f., .t.) * * check colour selections if !(type("clr_frame")=="C") && box frame color clr_frame := iif(iscolor(), "W+/R", "W+/N") && hi white on red or high white on black endif (!(type("clr_frame")=="C") && box frame color) if !(type("clr_title")=="C") && box title color clr_title := iif(iscolor(), "BG+/R", "N/W") && hi cyan on red or black on white endif (!(type("clr_title") == "C") && box title color) if !(type("clr_text")=="C") && box text (messages) color clr_text := iif(iscolor(), "W+/R", "W/N") && hi white on red or white or white on black endif (!(type("clr_text") =="C") && box text (messages) color) if !(type("clr_instr")=="C") && box UsrPrompts color clr_instr := iif(iscolor(), "GR+/R", "N/W") && hi yellow on red or black on white endif (!type("clr_instr")=="C") && box UsrPrompts color) if !(type("clr_shadow")=="C") && shadow color clr_shadow := iif(iscolor(), "R/N", "W/N") && red on black or white on black endif (!(type("clr_shadow")=="C") && shadow color) * * * Initialize private variables llim_top := 3 llim_left := 1 llim_bott := maxrow()-3 llim_right := maxcol() action := 0 X := "" Counter := 0 * * Save current screen status lcurr_color := setcolor() && save color setting lcurr_row := ROW() && save current screen row lcurr_col := COL() && save current column CursorOn := set(_SET_CURSOR) && save cursor state set cursor off * save screen to MsgBoxScrn && save the whole screen * * determine type of frame to use if type("FRAME") == "N" * frame type was passed as a number DO CASE CASE FRAME == 0 lFrame := space(8) && no frame CASE FRAME == 2 lFrame := "ÉÍ»º¼ÍȺ" CASE FRAME == 3 lFrame := "Õ͸³¾ÍÔ³" CASE FRAME == 4 lFrame := "ÖÄ·º½ÄÓº" OTHERWISE lFrame = "ÚÄ¿³ÙÄÀ³" && default FRAME ENDCASE else * frame type was passed as a string lFrame := FRAME endif (type("FRAME") == "N") lframe := lframe + space(9 - len(lframe)) && take into account fill character * Find length of longest message No_Msgs := len(MsgArray) msg_len := 0 FOR Counter = 1 TO No_Msgs x := MsgArray[Counter] if len(x) > msg_len msg_len := len(x) endif (len(x) > msg_len) NEXT * now compare against the title & user prompt - use the largest x := len(MsgTitle) if msg_len < x msg_len := x endif (msg_len < x) x := len(UsrPrompt) if msg_len < x msg_len := x endif (msg_len < x) * box_len = msg_len + 4 && width of box including "³ " + " ³" * Find screen coordinates for MsgBox box do case case box_pos = "C" && centered box lTop := round(maxrow()/2, 0) - round((No_Msgs + 4) / 2, 0) lLeft := round(maxcol()/2, 0) - round(box_len / 2, 0) case box_pos = "UL" lTop := llim_top lLeft := llim_left if DrawShadw .and. ShadwSide = "L" lLeft = lLeft + 2 endif (DrawShadw .and. ShadwSide = "L") case box_pos = "LL" lTop := llim_bott - No_Msgs - 4 if DrawShadw lTop := lTop - 1 endif (DrawShadw) lLeft := llim_left if DrawShadw .and. ShadwSide = "L" lLeft := lLeft + 2 endif (DrawShadw .and. ShadwSide = "L") case box_pos = "UR" lTop := llim_top lLeft := llim_right - box_len if DrawShadw .and. ShadwSide = "R" lLeft := lLeft - 2 endif (DrawShadw .and. ShadwSide = "R") case box_pos = "LR" lTop := llim_bott - No_Msgs - 4 if DrawShadw lTop := lTop - 1 endif (DrawShadw) lLeft := llim_right - box_len if DrawShadw .and. ShadwSide = "R" lLeft := lLeft - 2 endif (DrawShadw .and. ShadwSide = "R") endcase * lBottom := lTop + 1 + No_Msgs + 2 lRight := lLeft + box_len - 1 * get to work -- Finally!! setcolor(clr_frame) set(_SET_CURSOR, SC_NONE) && no cursor * if lexplode * determine the centre of the box to start exploding from lexp_top := round((lBottom - lTop) / 2 + (lTop - 1), 0) lexp_left := round((lRight - lLeft) / 2 + (lLeft - 1), 0) lexp_bott := lexp_top + 1 lexp_right := lexp_left + 1 * * find out # of steps required to explode the box Tot_Exp := lexp_top - lTop + 1 && # of vertical steps to explode x := round(((lRight - lexp_right + 1) / 3), 0) && reduce horizontal by 1/3 Tot_Exp := iif(Tot_Exp < x, x, Tot_Exp) &&explode the samller of the two * if limplode PRIVATE ExplCoord[Tot_Exp, 4] && array to hold expl. scrn co-ordinates PRIVATE ExplScrn[Tot_Exp] && array to hold screen segment of exploding box endif (limplode) * for x = 1 to Tot_Exp @ lexp_top, lexp_left, lexp_bott, lexp_right BOX lFrame * if limplode * save the screen region to implode later ExplCoord[x] := {lexp_top, lexp_left, lexp_bott, lexp_right} ExplScrn[x] := savescreen(lexp_top, lexp_left, lexp_bott, lexp_right) endif (limplode) * if lexp_top > lTop lexp_top := lexp_top - 1 endif (lexp_top > lTop) if (lexp_left-3) > lLeft lexp_left := lexp_left - 3 endif ((lexp_left-3) > lLeft) if lexp_bott < lBottom lexp_bott := lexp_bott + 1 endif (lexp_bott < lBottom) if (lexp_right + 3) < lRight lexp_right := lexp_right + 3 endif ((lexp_right + 3) < lRight) next endif (lexplode) @ lTop, lLeft, lBottom, lRight BOX lFrame * * draw the shadow if DrawShadw setcolor(clr_shadow) * draw vertical shadow lcol_pos := iif(ShadwSide=="R", lRight + 1, lLeft - 2) for x = (lTop+1) to (lTop+No_Msgs+3) && 1 row below top & 2 below bottom @ x,lcol_pos say ShadwChar+ShadwChar next * draw horizontal shadow lCol_pos := iif(ShadwSide=="R", lLeft +1, lLeft - 2) @ x,lcol_pos say replicate(ShadwChar, (box_len + 1)) endif (DrawShadw) * draw the box title (error title) @ top of box lpoint := "}" rpoint := "{" ScrnMargn := int((box_len - len(MsgTitle)+2) / 2) setcolor(clr_frame) @ lTop, (lLeft+ScrnMargn-1) say rpoint @ lTop, (lLeft+ScrnMargn+len(MsgTitle)+2) say lpoint setcolor(clr_title) @ lTop,(lLeft+ScrnMargn) say space(1) + MsgTitle + space(1) * * draw the message lines setcolor(clr_text) @ (lTop+1), (lLeft+1) clear to (lBottom-1), (lRight-1) && clear area inside the box for x = 1 to No_Msgs @ (ltop+x+1), (lLeft+1) say space(1) + MsgArray[x] next * * draw user prompt(s) at bottom of box ScrnMargn := int((box_len - len(UsrPrompt)+2) / 2) setcolor(clr_frame) @ lBottom, (lLeft+ScrnMargn-1) say lPoint @ lBottom, (lLeft+ScrnMargn+len(UsrPrompt)+2) say rPoint setcolor(clr_instr) @ lBottom,(lLeft + ScrnMargn) say space(1) + UsrPrompt + space(1) * Get response (action) set(_SET_CURSOR, SC_INSERT) && lower half block cursor. if Resp_Ok Resp_Ok := .f. tone(400, 1) do while .not. Resp_Ok TONE(300,1) UserResp := upper(CHR(inkey(0))) && alphanumeric * if (UserResp $ ValidResp) Resp_Ok := .t. endif ((UserResp $ ValidResp)) enddo else tone(900, 1) inkey(0) endif (Resp_Ok) * Implode screen if needed if limplode .and. rest_scrn set(_SET_CURSOR, SC_NONE) && no cursor for x = Tot_Exp to 1 step -1 restscreen(ExplCoord[x, 1], ExplCoord[x, 2], ExplCoord[x, 3], ; ExplCoord[x, 4], ExplScrn[x]) next endif (limplode .and. rest_scrn) * setcolor(lcurr_color) && restore original color setting * set(_SET_CURSOR, CursorOn) && restore cursor status @ lcurr_row, lcurr_col say space(0) && restore cursor positions if rest_scrn restore screen from MsgBoxScrn endif (rest_scrn) * return { NIL } *!********************************************************************* *! *! Function: PRT_SCRN() *! *! Called by: ERRORHDL() *! *!********************************************************************* STATIC FUNCTION Prt_Scrn() * * ==> Syntax: * Prt_Scrn() * *) Grabs the contents of the screen, and sends them to the default *) print device - slow, but effective. * local y, x, ylimit, xlimit, scrn, PrtStatus, ConsoleStatus * PrtStatus := set(_SET_PRINTER) ConsoleStatus := set(_SET_CONSOLE) set print on set console off * ylimit := maxrow() xlimit := maxcol() for y=0 to ylimit * ie: row 0 to 24 scrn := savescreen(y, 0, y, xlimit) && grab the whole line. for x=1 to xlimit*2 step 2 * ie: column 0 to 79 ?? substr(scrn, x, 1) // print every other character next ?? chr(13)+chr(10) // output cr/lf next set(_SET_PRINTER, PrtStatus) set(_SET_CONSOLE, ConsoleStatus) * return { NIL } ***************************** eof *****************************