DOS Wares

home *** CD-ROM | disk | FTP | other *** search

/ DOS Wares / doswares.zip / doswares / DATABASE / DBASE5 / TEMPLATE.ZIP / FORM.COD < prev next >

Wrap

Text File | 1994-06-24 | 54.4 KB | 1,796 lines

// Module Name: FORM.COD FOR 5.0 // Description: This module produces dBASE 5.0 .FMT files // with popups for VALID clause field validation and // Context Sensitive Help for each field // Format (.fmt) File Template with POPUP field validation ------------------------------------------------------- Copyright (c) 1987, 1990, 1991, 1992, 1994 Borland International, Inc. This template will support POPUPs for VALID clause field validations and context sensitive help for each field. Example: In "ACCEPT value when" under "Edit options" enter, "POPUP" = "vendor->vendor_id ORDER vendor_id REQ SHADOW" -------------------------------------------------------- this will activate a popup if the data entered is invalid for that field and will also make the field REQUIRED. Explanation of the POPUP string follows: POPUP Indicates that a popup will be used for this field. vendor->vendor_id Indicates the .DBF to open and FIELD to use as validation. ORDER vendor_id Indicates which INDEX TAG to SEEK in. REQ Indicates the FIELD requires data (can't be empty). Leave REQ out if the field is NOT required. OPTIONAL! SHADOW Use shadowing effect on popups OPTIONAL! NOTE: The POPUP string must be entered with the quotes as in the example. -------------------------------------------------------------------------------- Explanation of the Context Sensitive Help file follows: If you want to create your own help file, here is the structure that is required. Structure for Help Database (.dbf): <first 6 chars. of the format file name>_H.dbf Field Field Name Type Width Dec Tag ------------------------------------------------- 1 FLD_NAME Character 10 Yes Field name to lookup on F1 2 FLD_HEADNG Character 25 No Heading to show user on window 3 FLD_HELP Memo 10 No Help text to show user ------------------------------------------------- Total 46 { include "form.def" // Form selectors include "builtin.def" // Builtin functions if getenv("dtl_debug") then debug(2) breakpoint( pick_debug ) endif // // Enum string constants for international translation // // Enum's for ON KEY labels AND error strings in FORM.DEF enum TRUE = 1, FALSE = 0, offset = 2, // Offset for lmarg() range_require = 2, // Bit for range required set valid_required = 4, // " " edit " " screen_width = 80, // Screen width for now err_ext = ".err" ; // var bnl_formname, // Name of BNL file to newframe if argument() has value create_error, // Indicates if there were problems creating programs arg_list; arg_list = argument() if arg_list != "" then bnl_formname = token( ",", arg_list, 1 ) if !newframe( bnl_formname ) then return -1; endif endif if FRAME_CLASS != form then // We are not processing a form object pause(wrong_class + any_key) goto NoGen; endif var fmt_name, // Format file name crlf, // line feed carry_flg, // Flag to test carry loop carry_cnt, // Count of the number of fields to carry carry_len, // Cumulative length of carry line until 75 characters carry_lent, // Total cumulative length of carry line base_name, // First 6 characters of the NAME selector procedure_name, // First 7 characters of the NAME selector udf_filename, // UDF file name grabbed from .scb file lookup_cnt, carry_first, // Flag to test "," output for carry fields color_flg, // Flag to if color should stay on am line line_cnt, // Count for total lines processed (Mulitple page forms) page_cnt, // Count for total pages processed (Mulitple page forms) temp, // tempory work variable cnt, // Foreach loop variable wnd_cnt, // Window counter wnd_names, // Window names so I can clear them at the bottom of the file default_drv, // dBASE default drive dB_status, // dBASE status before entering designer scrn_size, // Screen size when generation starts left_delimiter, // Delimiter to put around SAY right_delimiter,// Delimiter to put around SAY max_pop_row, // Maximum row that a popup or shadow can start display, // Type of display screen we are on is_popup, // POPUP validation requested is_help, // HELP (context sensitive) requested udf_file, // UDF file has been created hlp_name, // HELP .dbf name trow_positn, // Temporary variable for row_positn tcol_positn, // Temporary variable for col_positn at_pop, // "POPUP" is in FLD_OK_COND master_file, // Name of master alias based on first field on form workarea_dbfs,// DBF files opened on the surface , delimited color; // Color returned from getcolor function //----------------------------------------------- // Assign default values to some of the variables //----------------------------------------------- carry_flg = carry_first = carry_cnt = carry_len = carry_lent = wnd_cnt = line_cnt = color_flg = cnt = 0 crlf = chr(10) master_file = workarea_dbfs = temp = "" page_cnt = 1 is_popup = is_help = udf_file = 0 left_delimiter = right_delimiter = "\"" procedure_name = lower( rtrim( substr( NAME, 1, 7 ))) base_name = lower( rtrim( substr( NAME, 1, 6 ))) udf_filename = "U_" + base_name //-------------------------------------------------------- // Determine the size of the screen and the max row that a // help and fill popup can extend to. //-------------------------------------------------------- screen_size() dB_status = numset(_flgstatus) scrn_size = (!db_status ? scrn_size + 3 : scrn_size) max_pop_row = scrn_size - 3; //------------------------------- // Create Format file //------------------------------- if !make_Fmt() then goto nogen header() // Print Header in the Format file fmt_file_initialization() // Format file initializtion code fmt_file_body() // @ SAY GET Processing fmt_file_exit() // Format file exit code make_pop_code() // Create the Procedure File for POPUP's if required make_help_code() // Make procedures for the help system if is_popup || is_help then make_general_procs(); endif fileerase(fmt_name+".fmo") nogen: return 0; //--------------------------------------- // Template user defined functions follow //--------------------------------------- define fmt_file_initialization() // // Format file initialization code // } *-- Format file initialization code -------------------------------------------- *-- Some of these PRIVATE variables are created based on CodeGen and may not *-- be used by your particular .fmt file PRIVATE ll_talk, ll_cursor, lc_display, lc_status, ll_carry, lc_proc IF SET("TALK") = "ON" SET TALK OFF ll_talk = .T. ELSE ll_talk = .F. ENDIF ll_cursor = SET("CURSOR") = "ON" SET CURSOR ON lc_display = SET("DISPLAY") { set_screen_mode(); } lc_status = SET("STATUS") *-- SET STATUS was \ {if dB_status then} ON when you went into the Forms Designer. IF lc_status = "OFF" SET STATUS ON {else} OFF when you went into the Forms Designer. IF lc_status = "ON" SET STATUS OFF {endif} ENDIF //----------------------------------------------------------------------- // Process fields to build "SET CARRY" and WINDOW commands. //----------------------------------------------------------------------- { foreach FLD_ELEMENT flds if FLD_CARRY then carry_flg = 1; ++carry_cnt ; endif if chr(FLD_VALUE_TYPE) == "M" and FLD_MEM_TYP and wnd_cnt < 20 then ++wnd_cnt; wnd_names = wnd_names + "wndow" + wnd_cnt + ","; new_page(flds); } *-- Window for memo field {cap_first(FLD_FIELDNAME)}. DEFINE WINDOW { Window_Def(flds)}\ { endif next flds print(crlf); if carry_flg then } ll_carry = SET("CARRY") = "ON" SET CARRY ON *-- Fields to carry forward during APPEND. SET CARRY TO{tabto(41)}&& Clear previous SET CARRY TO list SET CARRY TO { Carry_Flds()} {endif} { if check_for_popups() then } ON KEY LABEL F2 ?? chr(7) { output_set_proc_code();} DO S_{procedure_name}{tabto(41)}&& Open up Lookup Files { endif if check_for_help() then if !is_popup then} { output_set_proc_code();} { endif} ON KEY LABEL F1 DO Help WITH VARREAD() { endif return; // eof - fmt_file_init() enddef //-------------------------------------------------------------- define fmt_file_body() var and_loc, or_loc; } *-- @ SAY GETS Processing. ----------------------------------------------------- *-- Format Page: {page_cnt = 1 page_cnt} {line_cnt = wnd_cnt = 0 foreach ELEMENT k color = getcolor(FLD_DISPLAY, FLD_EDITABLE) // get color of element if new_page(k) then } READ *-- Format Page: {page_cnt} { endif // if ELEMENT_TYPE == @TEXT_ELEMENT or ELEMENT_TYPE == @FLD_ELEMENT then if FLD_FIELDTYPE == calc then } *-- Calculated field: {cap_first(FLD_FIELDNAME)} - {FLD_DESCRIPT} { endif if FLD_FIELDTYPE == memvar then } *-- Memory variable: {cap_first(FLD_FIELDNAME)} { endif} @ {nul2zero(ROW_POSITN) - line_cnt},{nul2zero(COL_POSITN)} \ { endif if ELEMENT_TYPE == @BOX_ELEMENT then } @ {box_coordinates(k)}\ { endif} // { case ELEMENT_TYPE of @TEXT_ELEMENT: // Certain control characters can cause dBASE problems ie, ASCII(13,26,0) // so the form designer will either send them to us as a string if they are // all the same character or as individual characters if they differ. We // handle this by using the chr() function to "SAY" them in dBASE. } SAY \ { if asc(TEXT_ITEM) < 32 then if len(TEXT_ITEM) == 1 then} CHR({asc(TEXT_ITEM)}) \ { else} REPLICATE(CHR({asc(TEXT_ITEM)}), {len(TEXT_ITEM)}) \ { endif else if substr(TEXT_ITEM,1,1) == "\"" then // Double quote is being used on the design surface need to use // brackets "[]" as delimiters left_delimiter = "[" right_delimiter = "]" endif left_delimiter + TEXT_ITEM + right_delimiter} \ { left_delimiter = right_delimiter = "\"" endif outcolor()} { @Box_element: outbox(BOX_TYPE, BOX_SPECIAL_CHAR)} { outcolor()} { @FLD_ELEMENT: if !FLD_EDITABLE then; // its a SAY} SAY \ { if FLD_FIELDTYPE == calc then // Loop thru expression in case it is longer than 237 foreach FLD_EXPRESSION fcursor in k FLD_EXPRESSION} { next} // Output a space after the Fld_expression and get ready for picture clause \ { else // not a editable field if FLD_FIELDTYPE == dbf then temp = "" else temp = "m->" endif temp + cap_first(FLD_FIELDNAME)} \ { endif if Ok_Template(k) then} PICTURE "{picture_for_say(k);}" \ { endif else // it's a get} GET \ { if FLD_FIELDTYPE == dbf then temp = "" if !master_file then master_file = FLD_FILENAME endif else temp = "m->" endif temp + cap_first(FLD_FIELDNAME)} \ { if chr(FLD_VALUE_TYPE) == "M" && FLD_MEM_TYP then if wnd_cnt < 20 then ++wnd_cnt endif if Fld_mem_typ == 1}OPEN {endif}WINDOW wndow{wnd_cnt} \ { endif if Ok_Template(k) then} PICTURE {picture_for_get(k);} \ { endif if FLD_L_BOUND or FLD_U_BOUND then color_flg = 1;} ; RANGE {if range_require & FLD_EDITABLE then}REQUIRED {endif}\ { FLD_L_BOUND}{if FLD_U_BOUND then},{FLD_U_BOUND}{endif} \ { endif if FLD_OK_COND then color_flg = 1;} ; { if at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" and ok_coordinates( k, 2, 1, bad_pick ) then // A POPUP is desired for showing coded values, redo the // VALID clause to call a UDF based on "U_" + FLD_FIELDNAME } VALID { if valid_required & FLD_EDITABLE || is_required( FLD_OK_COND ) then}REQUIRED {endif}\ { get_udfname(FLD_FIELDNAME)}( {cap_first(FLD_FIELDNAME)} ) \ { and_loc = at( ".AND.", upper(FLD_OK_COND) ); if and_loc > 0 then substr( FLD_OK_COND, and_loc )} \ { endif else if !(at("POPUP", upper(ltrim(FLD_OK_COND))) == "2") then } VALID {if valid_required & FLD_EDITABLE then}REQUIRED {endif}{FLD_OK_COND} \ { endif endif if FLD_REJ_MSG then} ; ERROR \ { if !at("IIF", upper(FLD_REJ_MSG))}"{endif}{FLD_REJ_MSG}\ { if !at("IIF", upper(FLD_REJ_MSG))}"{endif} \ { endif endif // FLD_OK_COND if FLD_ED_COND then color_flg = 1;} ; WHEN {FLD_ED_COND} \ { endif if FLD_DEF_VAL then color_flg = 1;} ; DEFAULT {FLD_DEF_VAL} \ { endif if FLD_HLP_MSG then color_flg = 1;} ; MESSAGE \ { if !at("IIF", upper(FLD_HLP_MSG))}"{endif}{FLD_HLP_MSG}\ { if !at("IIF", upper(FLD_HLP_MSG))}"{endif} \ { endif endif // FLD_EDITABLE } { outcolor()} { color_flg = 0; otherwise: goto getnext; endcase } //Leave the above blank line, it forces a line feed! //----------------- // End of @ SAY GET //----------------- { ++cnt; getnext: next k return; // eof - fmt_file_body() enddef //-------------------------------------------------------------- define fmt_file_exit() } *-- Format file exit code ----------------------------------------------------- *-- SET STATUS was \ {if dB_status then} ON when you went into the Forms Designer. IF lc_status = "OFF" && Entered form with status off SET STATUS OFF && Turn STATUS "OFF" on the way out {else} OFF when you went into the Forms Designer. IF lc_status = "ON" && Entered form with status on SET STATUS ON && Turn STATUS "ON" on the way out {endif} ENDIF {if carry_flg then} IF .NOT. ll_carry SET CARRY OFF ENDIF {endif} IF .NOT. ll_cursor SET CURSOR OFF ENDIF IF SET( "DISPLAY" ) <> lc_display SET DISPLAY TO &lc_display. && Reset Screen size if changed ENDIF {if wnd_names then} RELEASE WINDOWS {substr(wnd_names, 1, (len(wnd_names) - 1))} {endif} RELEASE {if carry_flg then}ll_carry,{endif}lc_fields,lc_status { if is_help then} ON KEY LABEL F1 { endif if is_popup or is_help then} ON KEY LABEL F2 { if is_popup then} DO C_{procedure_name}{tabto(41)}&& Close up Lookup Files { endif} SET PROCEDURE TO (lc_proc){tabto(41)}&& Re-Establish any open procedure file RELEASE lc_proc { endif} IF TYPE( "ll_echo" ) = "L" IF ll_echo SET ECHO ON ENDIF ENDIF IF ll_talk SET TALK ON ENDIF *-- EOP: {filename(fmt_name)}FMT {return; // eof - fmt_file_exit() enddef define picture_for_get(c) //-------------------------------------------------------------- // DESCRIPTION // Build a dBASE Picture template for a @ GET command // //-------------------------------------------------------------- if at("\"", c.FLD_TEMPLATE) or at("'", c.FLD_TEMPLATE)then left_delimiter = "[" right_delimiter = "]"; endif left_delimiter} { if c.FLD_PICFUN then}@{c.FLD_PICFUN}\ { if at("S", c.FLD_PICFUN) then}{c.FLD_PIC_SCROLL}{endif}\ {//leave this space}\ { endif if at("M", c.FLD_PICFUN) then c.FLD_PIC_CHOICE}\ { else c.FLD_TEMPLATE}\ { endif right_delimiter} { left_delimiter = right_delimiter = "\"" return; enddef //-------------------------------------------------------------- define picture_for_say(c) if c.FLD_PICFUN then}@{c.FLD_PICFUN}\ { if at("S", c.FLD_PICFUN) then}{c.FLD_PIC_SCROLL}{endif}\ {//leave this space}\ { endif if !at("M", c.FLD_PICFUN) then c.FLD_TEMPLATE}\ { endif return; enddef define make_pop_code() //-------------------------------------------------------------- // Create the Procedure File for POPUP's if required //-------------------------------------------------------------- var lookup_dbf, // store get_file(text_line1) for faster processing look_alias, // Lookup alias, diff from DBF if DBF starts with number look_1st, // 1st char of lookup DBF file is_format, // is there a format file fmt_name, // Name of the format file to use with browse temp_name, // store get_popname(text_line1) prompt_field, // Name of field to build popup with temp_key, tag_name, // tag name for the order temp_org_file,// store get_org_file( text_line1 ) lookup_alias_on_form, lookup_dbf_matches, is_in_detail // Flag for in a detail region ; if is_popup then if !make_udf() then return 0; endif udf_header() } PROCEDURE S_{procedure_name} *-------------------------------------------------------------------------------- * DESCRIPTION * Open data (.dbf) files for Lookup operations & faster processing *-------------------------------------------------------------------------------- PRIVATE lc_alias, ll_esc ll_esc = SET( "ESCAPE" ) = "ON" SET ESCAPE OFF lc_alias = ALIAS(){tabto(41)}&& Capture current alias { foreach FLD_ELEMENT flds at_pop = at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" ? 1 : 0; if at_pop then lookup_dbf = Cap_first( get_file(FLD_OK_COND) ); look_1st = ASC( substr( lookup_dbf, 1, 1 ) ); look_alias = ( look_1st > 47 && look_1st < 58 ) ? "A" + lookup_dbf : lookup_dbf; tag_name = get_key(FLD_OK_COND); prompt_field = get_field(FLD_OK_COND); lookup_dbf_matches = (upper(lookup_dbf) == FLD_FILENAME) ? TRUE : FALSE; if not at("," + lookup_dbf, workarea_dbfs) then workarea_dbfs = workarea_dbfs + "," + lookup_dbf; } IF TYPE("g_{lower(lookup_dbf)}") = "U" PUBLIC g_{lower(lookup_dbf)} IF SELECT("{lookup_dbf}") = 0 IF FILE( "{lookup_dbf}.DBF" ) SELECT SELECT() USE {lookup_dbf} NOLOG ALIAS {look_alias} g_{lower(lookup_dbf)} = 1{tabto(41)}&& File was opened for the first time IF TAGNO( "{tag_name}" ) = 0 DO _Err_Box WITH [{tag_err} ] + [{tag_name}] USE RELEASE g_{lower(lookup_dbf)} RELEASE gl_{lookup_dbf} PUBLIC gl_{lookup_dbf} ENDIF IF TYPE( "{look_alias}->{prompt_field}" ) = "U" DO _Err_Box WITH [{var_err} ] + [{look_alias}->{prompt_field}] USE RELEASE g_{lower(lookup_dbf)} RELEASE gl_{lookup_dbf} PUBLIC gl_{lookup_dbf} ENDIF ELSE DO _Err_Box WITH "{lookup_dbf}.DBF " + [{file_err}] RELEASE g_{lower(lookup_dbf)} RELEASE gl_{lookup_dbf} PUBLIC gl_{lookup_dbf} ENDIF ELSE g_{lower(lookup_dbf)} = 2{tabto(41)}&& File was opened outside of this program ENDIF ELSE *-- File was already opened by a program generated from Form.gen g_{lower(lookup_dbf)} = g_{lower(lookup_dbf)} + 1 ENDIF { endif endif next; } SELECT ( lc_alias ) IF ll_esc SET ESCAPE ON ENDIF RETURN *-- EOP: S_{procedure_name} PROCEDURE C_{procedure_name} *-------------------------------------------------------------------------------- * DESCRIPTION * Close Lookup files on exit of the .fmt, if they are not used * by other calling .fmt files *-------------------------------------------------------------------------------- PRIVATE ll_esc ll_esc = SET( "ESCAPE" ) = "ON" SET ESCAPE OFF { workarea_dbfs = "" foreach FLD_ELEMENT flds at_pop = at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" ? 1 : 0; if at_pop then lookup_dbf = get_file(FLD_OK_COND) look_1st = ASC( substr( lookup_dbf, 1, 1 ) ); look_alias = ( look_1st > 47 && look_1st < 58 ) ? "A" + lookup_dbf : lookup_dbf; if not at("," + lookup_dbf, workarea_dbfs) then workarea_dbfs = workarea_dbfs + "," + lookup_dbf; } DO CASE CASE TYPE("g_{lower(lookup_dbf)}") = "U" *-- Exiting out of the form! Lookup file was not opened up properly RELEASE gl_{lookup_dbf} CASE g_{lower(lookup_dbf)} = 1 USE IN {look_alias} RELEASE g_{lower(lookup_dbf)} OTHERWISE g_{lower(lookup_dbf)} = g_{lower(lookup_dbf)} - 1 ENDCASE { endif endif next; } IF ll_esc SET ESCAPE ON ENDIF RETURN *-- EOP: C_{procedure_name} { line_cnt = lookup_cnt = 0 page_cnt = 1 foreach FLD_ELEMENT flds at_pop = at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" ? 1 : 0; new_page(flds) if at_pop then trow_positn = nul2zero(ROW_POSITN) - line_cnt tcol_positn = nul2zero(COL_POSITN) lookup_dbf = get_file(FLD_OK_COND); look_1st = ASC( substr( lookup_dbf, 1, 1 ) ); look_alias = ( look_1st > 47 && look_1st < 58 ) ? "A" + lookup_dbf : lookup_dbf; tag_name = get_key(FLD_OK_COND); prompt_field = get_field(FLD_OK_COND); color = getcolor(FLD_DISPLAY, FLD_EDITABLE) // get color of element if !ok_coordinates(flds, 2, 0, "") then loop endif } FUNCTION {get_udfname(FLD_FIELDNAME)} PARAMETER fld_name *{replicate("-",69)} PRIVATE ALL LIKE l?_* PRIVATE esckey, fld_name, rtn_fld ll_esc = SET( "ESCAPE" ) = "ON" SET ESCAPE OFF ll_return = .F. IF TYPE( "gl_{lookup_dbf}" ) = "L"{tabto(41)}&& Was lookup file opened? IF ll_esc{tabto(41)}&& It wasn't, so return back to the form SET ESCAPE ON ENDIF RETURN(.T.){tabto(41)}&& With no data validation ENDIF { if !is_required(FLD_OK_COND) then} IF ISBLANK(fld_name){tabto(41)}&& Not a required field IF ll_esc SET ESCAPE ON ENDIF RETURN (.T.){tabto(41)}&& Return since it's a blank field ENDIF { endif} EscKey = 27{tabto(41)}&& 27 represents the ESC key lc_alias = ALIAS(){tabto(41)}&& Grab current workarea SELECT {look_alias}{tabto(41)}&& Select the lookup file lc_order = ORDER(){tabto(41)}&& Save any existing order SET ORDER TO {tag_name}{tabto(41)}&& Set the order to the lookup key ll_exact = SET("EXACT") = "ON"{tabto(41)}&& Store value of EXACT SET EXACT ON { if chr(FLD_VALUE_TYPE) == "C" then} fld_name = IIF( ISBLANK( TRIM( fld_name)), fld_name, TRIM( fld_name)) { endif} SEEK fld_name IF .NOT. ll_exact{tabto(41)}&& Restore SET EXACT to org. value SET EXACT OFF ENDIF IF .NOT. FOUND() DEFINE POPUP {get_popname(FLD_OK_COND)} FROM \ { if trow_positn < max_pop_row then trow_positn + 1},{tcol_positn} ; TO {scrn_size-1},{tcol_positn + len(FLD_TEMPLATE) + 1} ; { else trow_positn - 11},{tcol_positn} ; TO {trow_positn - 1},{tcol_positn + len(FLD_TEMPLATE) + 1} ; { endif} PROMPT FIELD {prompt_field} ; MESSAGE {select_msg1} ON SELECTION POPUP {get_popname(FLD_OK_COND)} DEACTIVATE POPUP { if chr(FLD_VALUE_TYPE) == "C" then} KEYBOARD TRIM(fld_name) { endif} SAVE SCREEN TO temp { if is_shadow(FLD_OK_COND) and ok_coordinates( flds, 4, 1, bad_shadow ) then } DO shadowg WITH {get_pop_shadow(FLD_TEMPLATE);} { endif } ACTIVATE POPUP {get_popname(FLD_OK_COND)} rtn_fld = PROMPT(){tabto(41)}&& Get user choice from pick list ln_bar = BAR(){tabto(41)}&& Capture bar number to check for esc RELEASE POPUP {get_popname(FLD_OK_COND)} RESTORE SCREEN FROM temp IF ln_bar <> 0 @ {trow_positn},{tcol_positn} GET rtn_fld \ { if Ok_Template(flds) then} PICTURE {picture_for_get(flds);} \ { outcolor()} { endif} CLEAR GETS REPLACE {cap_first(FLD_FILENAME)}->{cap_first(FLD_FIELDNAME)} WITH \ { if chr(FLD_VALUE_TYPE) == "C" then} rtn_fld { else} VAL(rtn_fld) { endif} ll_return = .T. ELSE ll_return = .F. { if !is_required(FLD_OK_COND) then } IF ISBLANK(fld_name){tabto(41)}&& Not a required field, so return ll_return = .T. ENDIF { endif } ENDIF ELSE ll_return = .T. ENDIF IF .NOT. ISBLANK( lc_order ){tabto(41)}&& If there was a order on lookup file SET ORDER TO ( lc_order ){tabto(41)}&& Set it back to its original setting ENDIF SELECT (lc_alias){tabto(41)}&& Go back to the edit file IF ll_esc SET ESCAPE ON ENDIF RETURN (ll_return) *-- EOP: {get_udfname(FLD_FIELDNAME)} { endif next flds print("*"+replicate("-",78)+crlf);} { endif return; // eof - make_pop_code() enddef //-------------------------------------------------------------- define make_help_code() //------------------------------------ // Make procedures for the help system //------------------------------------ if is_help then // If the udf file has not already been created, make it. if not udf_file then if !make_udf() then return 0; endif // Put up the UDF header udf_header() endif // Make procedures for the help system make_help() endif if is_help or is_popup then // Make shadow procedures make_shadow_procs() endif return; enddef //-------------------------------------------------------------- define header() // Print Header in program var len_filename, file_name; file_name = filename(fmt_name); len_filename = len( file_name ); if substr( file_name, len_filename, 1 ) == "." then file_name = substr( file_name, 1, len_filename - 1 ) + ".FMT"; else file_name = file_name + ".FMT"; endif } *{replicate( "-", 69)} * Name.......: {file_name} * Date.......: {ltrim( substr( date(),1,8))} * Version....: dBASE {db_version_no}, Format * Notes......: Format files use "" as delimiters! *{replicate( "-", 69)} { enddef //-------------------------------------------------------------- define udf_header() // Print Header in UDF program var len_filename, file_name; file_name = filename(fmt_name); len_filename = len( file_name ); if substr( file_name, len_filename, 1 ) == "." then file_name = substr( file_name, 1, len_filename - 1 ) + ".FMT"; else file_name = file_name + ".FMT"; endif } *{replicate( "-", 69)} * Name....: U_{rtrim(substr(name,1,6))}.PRG * Date....: {ltrim(SUBSTR(date(),1,8))} * Version.: dBASE {db_version_no}, Procedure for Format * Notes...: Procedure file for VALID POPUPs and/or Context Sensitive Help * for {file_name} { if master_file then} * The Master file for the form is assumed to be {master_file}. { endif} *{replicate( "-", 69)} { lmarg(offset)} PRIVATE ll_oldtalk IF SET( "TALK" ) = "ON" SET TALK OFF ll_oldtalk = .T. ELSE ll_oldtalk = .F. ENDIF *-- {can_not_run} DO _Err_Box WITH "{can_not_run}" IF ll_oldtalk SET TALK ON ENDIF { lmarg(0)} RETURN { enddef //-------------------------------------------------------------- define ok_template(cur) if cur.FLD_TEMPLATE && !(chr(cur.FLD_VALUE_TYPE) == "D" || chr(cur.FLD_VALUE_TYPE) == "M" || chr(cur.FLD_VALUE_TYPE) == "G" || chr(cur.FLD_VALUE_TYPE) == "B" ) then return 1; else return 0; endif enddef //-------------------------------------------------------------- define ok_coordinates(cur, // Current cursor xtra_width, // Additional width to check ie, shadow want_message, // Display message flag 0:No 1:Yes message) // Message to display to user // Check to see if coordinates of popup or shadow will fit on screen // based on the dimensions of the current field if nul2zero(cur.COL_POSITN) + len(cur.FLD_TEMPLATE) + xtra_width > 80 then if want_message then beep(2) // UDF in builtin.def cls() say_center(10,"Error on Field: " + cur.FLD_FIELDNAME) say_center(12, message) pause(any_key) endif return 0; else return 1; endif enddef //-------------------------------------------------------------- define getcolor(f_display, // Color of the current field f_editable // Field is SAY or GET ) // Determines the color from f_display and f_editable (GET or SAY) enum Foreground = 7, Intensity = 8, // Color Background = 112, MIntensity = 256, Reverse = 512, // Mono Underline =1024, Blink =2048, default =32768; // Screen set to default var forgrnd, enhanced, backgrnd, blnk, underln, revrse, use_colors, incolor; incolor="" use_colors = default & f_display forgrnd = Foreground & f_display enhanced = (Intensity & f_display) || (MIntensity & f_display) backgrnd = Background & f_display blnk = Blink & f_display underln = Underline & f_display revrse = Reverse & f_display if not use_colors then // Use system colors, no colors set in designer if backgrnd then backgrnd = backgrnd/16 endif if (display != mono and display != mono43) then case forgrnd of 0: incolor = "n" 1: incolor = "b" 2: incolor = "g" 3: incolor = "bg" 4: incolor = "r" 5: incolor = "rb" 6: incolor = "gr" 7: incolor = "w" endcase else incolor = "w" endif if revrse then incolor = incolor + "i" endif if underln then incolor = incolor + "u" endif if enhanced then incolor = incolor + "+" endif if blnk then incolor = incolor + "*" endif incolor = incolor + "/" if (display != mono and display != mono43) then case backgrnd of 0: incolor = incolor + "n" 1: incolor = incolor + "b" 2: incolor = incolor + "g" 3: incolor = incolor + "bg" 4: incolor = incolor + "r" 5: incolor = incolor + "rb" 6: incolor = incolor + "gr" 7: incolor = incolor + "w" endcase else incolor = incolor + "n" endif if f_editable and incolor then incolor = incolor + "," + incolor endif endif // use no colors return alltrim(incolor); enddef //-------------------------------------------------------------- define outbox(mbox, // Border type mchar // Special character of border ) // Output the of Box border and character if any var result; case mbox of 0: result = " " // single 1: result = " DOUBLE " 2: result = " CHR("+mchar+") " endcase return result; enddef //-------------------------------------------------------------- define outcolor() // Output the of color of the @ SAY GET or Box var result; result = ""; if len(color) > 0 then if color_flg then // If flag is set output a dBASE continuation ";" result = ";" + crlf + space(3) endif result = result + "COLOR " + color + " " endif return result; enddef //-------------------------------------------------------------- define window_def(cur) // Build dBASE window command var result; result = "wndow" + wnd_cnt + " FROM " + Box_Coordinates(cur); result = result + outbox(cur.BOX_TYPE, cur.BOX_SPECIAL_CHAR); color = getcolor(cur.FLD_DISPLAY, cur.FLD_EDITABLE); result = result + outcolor(); return result; enddef //-------------------------------------------------------------- define box_coordinates(cur) // Pass in foreach cursor // // Build box coordinates for a dBASE window command // var result, temp_page, line_cnt, cur_box_top, cur_row_positn, scrn_num4_win, scrn_num4_fld, cur_box_left; cur_box_top = nul2zero(cur.BOX_TOP); cur_row_positn = nul2zero(cur.ROW_POSITN); cur_box_left = nul2zero(cur.BOX_LEFT); if cur.FLD_MEM_TYP then // If MEMO window scrn_num4_win = cur_box_top / scrn_size; scrn_num4_fld = cur_row_positn / scrn_size; if scrn_num4_win != scrn_num4_fld then // If window not on same screen cur_box_top = ( cur_box_top % scrn_size ) + scrn_size + 1; endif endif temp_page = cur_box_top / scrn_size; line_cnt = (scrn_size * temp_page) + (1 * temp_page); result = cur_box_top - line_cnt +","; result = result + cur_box_left + " TO "; temp = cur_box_top + cur.BOX_HEIGHT - line_cnt - 1; if temp > scrn_size then temp = scrn_size; endif result = result + temp + "," + ( cur_box_left + cur.BOX_WIDTH - 1 ); return result; enddef //-------------------------------------------------------------- define carry_flds() // Build dBASE SET CARRY command carry_len = carry_lent = 13 carry_first = 0 foreach FLD_ELEMENT flds if FLD_CARRY then carry_len = carry_len + len(FLD_FIELDNAME + ",") carry_lent = carry_lent + len(FLD_FIELDNAME + ",") if carry_lent > 1000 then print(crlf + "SET CARRY TO ") carry_len = carry_lent = 13 endif if carry_len > 75 then print(";" + crlf + " ") carry_len = 2 endif temp = cap_first(FLD_FIELDNAME) if !carry_first then print(temp) carry_first = 1 else print("," + temp) endif endif next flds print(" ADDITIVE"); return; enddef //-------------------------------------------------------------- define make_fmt() // Attempt to create program (fmt) file. default_drv = strset(_defdrive) // grab default drive from dBASE fmt_name = FRAME_PATH + NAME // Put path on to object name if not fileok(fmt_name) then if !default_drv then fmt_name = NAME else fmt_name = default_drv + ":" + NAME endif endif // fmt_name = upper(fmt_name) if not create(fmt_name+".fmt") then pause(fileroot(fmt_name) +".fmt" + read_only + any_key) return 0; endif return 1; enddef //-------------------------------------------------------------- define make_udf() // Attempt to create dBASE procedure (prg) file. var udf_root_file_name; udf_root_file_name = frame_path + "u_" + rtrim(substr(name,1,6)) if not create( udf_root_file_name + ".prg") then pause(udf_root_file_name + ".prg" + read_only + any_key) return 0; endif // Force dBASE to recompile the .prg fileerase(udf_root_file_name + ".DBO") udf_file = 1 // Global flag to determine if UDF file was created return 1; enddef //-------------------------------------------------------------- define check_for_popups() // Check for "popup" string for this fmt file foreach FLD_ELEMENT flds if at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" then is_popup = 1 exit endif next flds return is_popup; enddef //-------------------------------------------------------------- define check_for_help() // Check for help support for this fmt file // Looking for a .dBF with the same name as the .fmt file hlp_name = frame_path + substr(fileroot(fmt_name), 1, 6) + "_H" if fileexist(hlp_name + ".dbf") and fileexist(hlp_name + ".dbt") then is_help = 1 // Global flag for help support endif return is_help; enddef define new_page(cur) // Pass in foreach cursor //---------------------------------------------------------------------- // NAME // New_Page - Check for a page break and adjusts line_cnt and page_cnt // // DESCRIPTION // New_Page() will determine the top line on the screen for the // object specified by the cursor <cur> and is assigned to the // global variable, <line_cnt>. If the object is on a new page, // the global variable, <page_cnt>, is adjusted to the new page. // // New_Page() will return a TRUE value if a page break occured, // otherwise it will return a FALSE value. // // EXAMPLE // foreach ELEMENT k // if new_page( k ) // ... page break occured // endif // next k; // // GLOBAL VARIABLES // line_cnt = line number for the top line on the given page // page_cnt = page number for the object, starting at 1 // //---------------------------------------------------------------------- var cur_row_positn, temp_page; cur_row_positn = nul2zero( cur.ROW_POSITN ) if cur_row_positn - line_cnt > scrn_size then temp_page = cur_row_positn / scrn_size line_cnt = (scrn_size * temp_page) + (1 * temp_page) page_cnt = temp_page + 1 return TRUE; endif return FALSE; enddef //-------------------------------------------------------------- define parse_line( before, // Out: chars before the look_for string input, // In: line being parsed look_for // In: string searched for ) // Rtn: chars after the look_for string // If the look_for sting is not found, the before sting will equal the // input string, and the returned value will be NUL var location; location = at(look_for, UPPER(input)) if location == 0 then before = input return ( "" ); endif before = substr( input, 1, location-1) return ( substr( input, location+len(look_for), len(input) ) ); // end: parse_line() enddef //-------------------------------------------------------------- // Parsing routines for pulling objects out of the VALID string // "POPUP" = "file->fld_name ORDER key_fld REQ" // 1234567890123456789012345678901234567890123 // 1 2 3 4 define get_file(valid_str) var s_arrow, // String "->" test, s_equal, // String "=" next_alpha, at_alias, s_before, // String before the searched for item r_target, // Remainder of the target string after item use_name; // Return for file s_arrow = "->" s_equal = "=" r_target = parse_line( s_before, valid_str, s_equal ) // ' "file->...' next_alpha = atalpha(r_target) // 3 at_alias = at(s_arrow, r_target) // 7 use_name = substr(r_target,next_alpha,at_alias-next_alpha) // 'file' return cap_first(use_name); enddef //-------------------------------------------------------------- define get_key(valid_str) var s_order, // String "ORDER " at_space, q_space, s_before, // String before the searched for item r_target, // Remainder of the target string after item order_tag; // Search TAG to ORDER BY s_order = "ORDER " r_target = parse_line( s_before, valid_str, s_order ) // 'key_fld REQ' at_space = at(" ",r_target) if at_space == 0 then order_tag = substr(r_target, 1, len(r_target)-1) // 'key_fld"' else q_space = at('"',r_target) if q_space != 0 && q_space < at_space then order_tag = substr(r_target, 1, q_space-1) else order_tag = substr(r_target, 1, at_space-1) endif endif return cap_first(order_tag); enddef //-------------------------------------------------------------- define get_field(valid_str) var s_arrow, // String "->" at_space, s_before, // String before the searched for item r_target, // Remainder of the target string after item fld_name; // Field name to lookup in target file s_arrow = "->" r_target = parse_line( s_before, valid_str, s_arrow ) // 'fld_name ORDER...' at_space = at(" ",r_target) fld_name = ( at_space == 0 ? r_target : substr(r_target, 1, at_space-1) ); return cap_first(fld_name); enddef //-------------------------------------------------------------- define get_popname(valid_str) // Create popup name return ( lower( "u_" + substr( get_field( valid_str),1,6) ) ); enddef //-------------------------------------------------------------- define get_pop_shadow(field_template) // Pass in FLD_TEMPLATE to deter. shadow if trow_positn < max_pop_row then trow_positn + 1},{tcol_positn},{scrn_size-1},{tcol_positn+len(Field_template)+1} { else trow_positn - 11},{tcol_positn},{trow_positn - 1},{tcol_positn+len(Field_template)+1} { endif return; enddef //--------------------------------------------------------------- define get_udfname(fld_str) // Create UDF name return cap_first( "u_" + substr( fld_str,1,6) ); enddef //-------------------------------------------------------------- define is_required(valid_str) // Determines if the field is required before moving to the next field return ( ( at(" REQ ", upper(valid_str)) ? 1 : 0 ) or ( at(" REQ\"", upper(valid_str)) ? 1 : 0 ) ); enddef //-------------------------------------------------------------- define is_shadow(valid_str) // Determines if the user wants shadowing for popup return ( ( at(" SHADOW ", upper(valid_str)) ? 1 : 0 ) or ( at(" SHADOW\"", upper(valid_str)) ? 1 : 0 ) ); enddef //-------------------------------------------------------------- define make_shadow_procs() // Make the dBASE code for shadowing } PROCEDURE Shadowg *{replicate("-",69)} * DESCRIPTION * Displays shadow that grows. Specify the same coord and the * window or popup to shadow. *{replicate("-",69)} PARAMETER x1,y1,x2,y2 PRIVATE x1,y1,x2,y2 x0 = x2+1 y0 = y2+2 dx = 1 dy = (y2-y1) / (x2-x1) DO WHILE x0 <> x1 .OR. y0 <> y1+2 @ x0,y0 FILL TO x2+1,y2+2 COLOR n+/n x0 = IIF(x0<>x1,x0 - dx,x0) y0 = IIF(y0<>y1+2,y0 - dy,y0) y0 = IIF(y0<y1+2,y1+2,y0) ENDDO RETURN *-- EOP: shadowg { return; enddef define make_general_procs() //-------------------------------------------------------------- // Make the dBASE core routines //-------------------------------------------------------------- } PROCEDURE _Err_Box PARAMETERS pc_msg *---------------------------------------------------------------------------- * NAME * _Err_Box - Display an error box * * SYNOPSIS * DO _Err_Box WITH <pc_msg> * * DESCRIPTION * _Err_Box will display the <pc_msg> string in a box and prompt the * user to press any key to continue processing. _Err_Box will display * the message based on the length of <pc_msg>. * * PARAMETERS * pc_msg - the error message to display in the box. If the length is * greater than 76, the trailing part is chopped off. * * EXAMPLE * DO _Err_Box WITH "Incorrect window size" * Displays the message in a window as follows at row 9 on the screen: * +------------------------------+ * | | * | Incorrect window size | * | | * | Press any key to continue... | * | | * +------------------------------+ * Note that the width of the window will increase to accommodate a longer * message string. * * LIMITATIONS * Truncates the message after 76 characters. Assumes an 80 character * wide screen. Looks best with SET CURSOR OFF. * *---------------------------------------------------------------------------- PRIVATE lc_anykey, lc_msg, lc_msglen, lc_win, ln_press, ln_width, ll_trap,; ll_escape lc_anykey = [Press any key to continue...] ln_press = LEN( lc_anykey ) lc_win = WINDOW() && Currently activated window if any lc_msg = LTRIM( RTRIM( pc_msg ) ) && Trimmed message ln_msglen = LEN( lc_msg ) && Trimmed length of message ln_width = 0 && Width of display area in window. ll_escape = SET("ESCAPE") = "ON" IF TYPE( "FXL_DEV" ) = "L" .AND. FXL_DEV SET ESCAPE ON ELSE SET ESCAPE OFF ENDIF *-- Determine the width needed for the window: IF ln_msglen <= ln_press ln_width = ln_press ELSE *-- Make sure the message fits in the window: IF ln_msglen > 76 lc_msg = LEFT( lc_msg, 76 ) ln_msglen = 76 ENDIF ln_width = ln_msglen ENDIF DEFINE WINDOW _err_box FROM 9, ((76 - ln_width) + .5) / 2 ; TO 15, (ln_width + 83) / 2 DOUBLE ln_width = ( ln_width + 2 ) *-- Display the message and prompt to the window and wait for a key press ACTIVATE WINDOW _err_box @ 1, ( ln_width - ln_msglen ) / 2 SAY lc_msg @ 3, ( ln_width - ln_press ) / 2 SAY lc_anykey SET CONSOLE OFF && For mouse click recognition WAIT SET CONSOLE ON *-- Clean up the window display and reactivate the previous window RELEASE WINDOW _err_box IF ISBLANK( lc_win ) ACTIVATE SCREEN ENDIF IF ll_escape SET ESCAPE ON ELSE SET ESCAPE OFF ENDIF RETURN *-- EOP: _Err_Box WITH pc_msg FUNCTION _Rat PARAMETERS pc_source, pc_target *-------------------------------------------------------------------- * NAME * _RAT - Version of AT() that starts from right. * * SYNOPSIS * _RAT( <expC>, <expC> ) * * DESCRIPTION * _RAT() takes two arguments, a source string and a target * string. It searches for the first occurrence of the source * within the target beginning on the right end of the string, * and returns an integer representing the first character * position of the matching occurrence. * * If the source string is not contained within the target * string, if the source string is longer than the target * string, or if the source string is null, 0 is returned. * * PARAMETER(S) * The first parameter is the string to find. The second * parameter is the string to search in. In theory, any * character expression should be legal. * * EXAMPLE(S) * * ? _RAT("A","ABABA") && Returns 5 * lc_var = _RAT("A test","A test A test") && Returns 8 * ? _RAT("Long string","short") && Returns 0 * *-------------------------------------------------------------------- PRIVATE lc_len m->lc_len = LEN( m->pc_target ) DO WHILE m->lc_len > 0 IF m->pc_source $ SUBSTR(m->pc_target, m->lc_len) EXIT ELSE m->lc_len = (m->lc_len - 1) ENDIF ENDDO RETURN m->lc_len *-- EOF: _Rat( pc_source, pc_target ) { return; enddef //-------------------------------------------------------------- define make_help() // Make the dBASE code for help } PROCEDURE Help PARAMETER lc_var *{replicate("-",69)} * DESCRIPTION * Activates the HELP window *{replicate("-",69)} { lmarg(offset)} PRIVATE ALL LIKE ??_* ON KEY LABEL F1{tabto(41)}&& Dsiable the F1 key during help IF .NOT. FILE("{fileroot(hlp_name)}.dbf") *-- Help file has been deleted or can't be found DO _Err_Box WITH "{help_err1}" + "{fileroot(hlp_name)}.dbf" RETURN ENDIF ll_cat = SET( "CATALOG" ) = "ON" SET CATALOG OFF SET CURSOR OFF *-- Select workarea and open Help dbf lc_area = ALIAS() *-- Open the HELP dbf file for the form SELECT SELECT() USE {fileroot(hlp_name)} ORDER fld_name NOUPDATE NOLOG ll_exact = SET("EXACT") = "ON" SET EXACT ON SEEK lc_var{tabto(41)}&& Search for the field name in help IF .NOT. ll_exact SET EXACT OFF ENDIF IF FOUND() *-- Define the coord for the help window ln_t = 5 ln_l = 6 ln_b = 15 ln_r = 74 ON KEY LABEL F3 DO Toggle DEFINE WINDOW z_help FROM ln_t+1, ln_l+2 TO ln_b-1, ln_r-2 NONE ON ERROR lc_error=error() SAVE SCREEN TO zz_help *-- Make Help Box DO shadowg WITH ln_t, ln_l, ln_b, ln_r @ ln_t+1, ln_l+1 CLEAR TO ln_b-1, ln_r-1 @ ln_t, ln_l TO ln_b, ln_r DOUBLE ln_memline = SET("MEMO") SET MEMOWIDTH TO 65 IF MEMLINES(fld_help) > 9 @ ln_t+1,ln_r SAY CHR(24) @ ln_b-1,ln_r SAY CHR(25) ENDIF lc_string = CHR(185)+ [ Help for ] + TRIM(fld_headng) +[ ] + CHR(204) lc_message = IIF(MEMLINES(fld_help) > 9, ; "{help_msg1 + help_msg2}", ; "{help_msg2}" ; ) @ ln_t,CENTER(lc_string,80) SAY lc_string @ 0,0 GET fld_help OPEN WINDOW z_help MESSAGE lc_message READ SET MEMOWIDTH TO ln_memline ON ERROR ON KEY LABEL F3 RELEASE WINDOW z_help RESTORE SCREEN FROM zz_help RELEASE SCREEN zz_help ELSE DO _Err_Box WITH [{help_err2} ] + lc_var ENDIF SET MESSAGE TO IF ll_cat SET CATALOG ON ENDIF SET CURSOR ON USE{tabto(41)}&& Close help file SELECT (lc_area){tabto(41)}&& Back to edit work area ON KEY LABEL F1 DO Help WITH VARREAD() { lmarg(0)} RETURN *-- EOP: HELP PROCEDURE Toggle *{replicate("-",69)} * DESCRIPTION * Toggles the Help message back to the original screen *{replicate("-",69)} { lmarg(offset)} PRIVATE ll_cons SAVE SCREEN to Toggle RESTORE SCREEN FROM zz_help SET MESSAGE TO "Press any key..." ll_cons = SET( "CONSOLE" ) = "ON" SET CONSOLE OFF WAIT IF ll_cons SET CONSOLE ON ENDIF RESTORE SCREEN FROM Toggle RELEASE SCREEN Toggle SET MESSAGE TO "Scroll thru Help: Ctrl-Home Exit Viewing Help: Ctrl-End See Org. Screen: F3" { lmarg(0)} RETURN *-- EOP: Toggle FUNCTION Center PARAMETER lc_string, ln_width *{replicate("-",69)} * NAME * Center() - Provide column needed to center a string in a width * * DESCRIPTION * The CENTER() function will return the starting column * coordinate to center the <lc_string> string within a width of * screen <ln_width>. The width of the screen would normally be * 80 colunms, but could just as well be the width of a window. * If there is an error condition, the returned result will equal 0. * If a numeric value is passed for the <expC> value, it will be * converted to a string. * * EXAMPLES * * @ 15,center(string,80) say string * * Will center the <string> withing 80 columns * *----------------------------------------------------------------------------- PRIVATE lc_result, lc_type IF .NOT. TYPE("ln_width") $ "FN"{tabto(41)}&& Force value to 0 for bad type lc_result = 0 ELSE lc_type = TYPE("lc_string") DO CASE CASE lc_type = "C" lc_width = (ln_width/2)-(LEN(lc_string)/2) CASE lc_type $ "NF" lc_width = (ln_width/2)-(LEN(ALLTRIM(STR(lc_string)))/2) CASE lc_type = "L" lc_width = (ln_width/2)-(1.5){tabto(41)}&& .T. or .F. have fixed len of 3 OTHERWISE lc_width = 0 ENDCASE ENDIF IF lc_width < 0{tabto(41)}&& Force negative values to 0 lc_width = 0 ENDIF RETURN ( lc_width ) *-- EOF: Center( lc_string, ln_width ) {return; enddef define output_set_proc_code() } *-- Set procedure to the lookup programs ll_echo = SET( "ECHO" ) = "ON" SET ECHO OFF lc_proc = SET("procedure"){tabto(41)}&& Store procedure file name IF FILE("{cap_first(udf_filename)}.prg") .OR. FILE("{cap_first(udf_filename)}.dbo") SET PROCEDURE TO {cap_first(udf_filename)} ELSE lc_fullpath = SET("FULLPATH") SET FULLPATH ON lc_setfmt = SET("FORMAT") *-- Pull out the file path from the format file for a prefix lc_slash = IIF( LEFT( OS(), 3 ) = "DOS", "\", "/" ) *-- Look for last slash in the string m->lc_len = LEN( lc_setfmt ) DO WHILE m->lc_len > 0 IF m->lc_slash $ SUBSTR(m->lc_setfmt, m->lc_len) EXIT ELSE m->lc_len = m->lc_len - 1 ENDIF ENDDO lc_fullnam = LEFT( lc_setfmt, m->lc_len ) + "{cap_first(udf_filename)}" IF FILE( lc_fullnam + ".prg" ) .OR. FILE( lc_fullnam + ".dbo" ) SET PROCEDURE TO ( lc_fullnam ) ELSE *-- Display the error message in a windowed box PRIVATE lc_anykey, lc_msg, lc_msglen, lc_win, ln_press, ln_width, ll_trap,; ll_escape lc_anykey = [Press any key to continue...] ln_press = LEN( lc_anykey ) lc_msg = "{proc_err} {cap_first(udf_filename)} {file_err}" ln_msglen = LEN( lc_msg ) ln_width = 0 ll_escape = SET("ESCAPE") = "ON" SET ESCAPE OFF *-- Determine the width needed for the window: IF ln_msglen <= ln_press ln_width = ln_press ELSE *-- Make sure the message fits in the window: IF ln_msglen > 76 lc_msg = LEFT( lc_msg, 76 ) ln_msglen = 76 ENDIF ln_width = ln_msglen ENDIF DEFINE WINDOW _err_box FROM 9, ((76 - ln_width) + .5) / 2 ; TO 15, (ln_width + 83) / 2 DOUBLE ln_width = ( ln_width + 2 ) *-- Display the message and prompt to the window and wait for a key press ACTIVATE WINDOW _err_box ? lc_msg AT ( ln_width - ln_msglen ) / 2 ? ? lc_anykey AT ( ln_width - ln_press ) / 2 SET CONSOLE OFF WAIT SET CONSOLE ON *-- Clean up the window display and reactivate the previous window RELEASE WINDOW _err_box IF ll_escape SET ESCAPE ON ELSE SET ESCAPE OFF ENDIF ENDIF IF lc_fullpath = "OFF" SET FULLPATH OFF ENDIF ENDIF{tabto(41)}&& UDF's won't run { return; enddef include "cm_udf.cod" // Template language UDFs // EOP FORM.COD }