Path: utzoo!attcan!utgpu!watmath!att!tut.cis.ohio-state.edu!cica!iuvax!mailrus!ames!ucsd!usc!hacgate!ashtate!dbase!awd
From: awd@dbase.UUCP (Alastair Dallas)
Newsgroups: comp.databases
Subject: Pop-up Picklist in dBASE IV (long!)
Keywords: dBASE IV, Ashton-Tate, Template Language
Message-ID: <191@dbase.UUCP>
Date: 8 Aug 89 18:01:26 GMT
Organization: Ashton Tate Devlopment Center Glendale, Calif.
Lines: 937


An earlier poster asked about popping up a picklist in dBASE IV.  I thought
the request seemed reasonable, but it's out of my area, so I asked Kirk Nason,
our resident expert.  Kirk and Bill Ramos had already developed the code
which follows, and it has been made available on the Ashton-Tate BBS, so
it's releasable here.

Hope it helps.

/alastair/

From Kirk Nason:

We have a template (formpop.cod) that allows you as a designer of a form to
embed popups in the form designer.  It uses the template language in dBASE to
determine the row and col to display the modified data.  Rather than having
dBASE do the grunt work we generated the proper dBASE code to redisplay the
data.

If you have the Developers edition of dBASE IV you can recompile it with
DTC.EXE, the dBASE IV template language compiler.

Here is the source to the template:
//
// Module Name: FORMPOP.COD
// Description: This module produces dBASE IV .FMT files 
//              with popups for VALID clauses
//              field validation
//

Format (.fmt) File Template with POPUP field validation
-------------------------------------------------------
Version 1.1.3 BETA TEST
Ashton-Tate (c) 1987, 1988, 1989
Written by Kirk J. Nason & Bill Ramos

This template will support POPUPs for VALID clause field validations.

Example: In "ACCEPT value when" under "Editing options" enter,
        "POPUP" = "vendor->vendor_id ORDER vendor_id REQ",
        -------------------------------------------------
        this will activate a popup if the data entered is invalid for 
        that field and will also make the field REQUIRED.

Explaination 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 to SEEK in.
REQ                Indicates the FIELD requires data (can't be empty).  Leave
                   REQ out if the field is NOT required.
NOTE: The POPUP string must be entered with the quotes as in the example.
{
//========================================================================
//$Header:   C:/test/user_grp/doc/form.cov   1.4   19 Jul 1989 11:25:40   WWR  $
//$Log:   C:/test/user_grp/doc/form.cov  $
//  
//     Rev 1.6   27 Jul 1989 11:25:40   KJN
//  Fixed the display of fieldname and entered value in the window above
//  the picklist
//
//     Rev 1.5   25 Jul 1989 11:25:40   KJN
//  Fixed search for "POPUP" to by putting UPPER() around selector name
//  Put nul2zero() around @ GET for value redisplay
//  
//     Rev 1.4   19 Jul 1989 11:25:40   WWR
//  On a non-required field, if Esc is pressed, and the initial value failed
//  the lookup, a false condition is returned, versus true.
//  
//     Rev 1.3   19 Jul 1989 11:16:28   WWR
//  Stripped out the WHEN logic for dBASE 1.0 bug, where a replace statement
//  in a WHEN UDF() will not do a REPLACE like a VALID UDF() can.
//  
//     Rev 1.2   19 Jul 1989 11:06:38   WWR
//  Fixed the problem with using numeric key values.  The TYPE() function is
//  used to determine if it's a numeric field being looked up.  If it is
//  the VAL() function is used to take the character PROMPT() value and
//  convert it.
//  Picture functions are now used when displaying data after the POPUP
//  selection is made.
//========================================================================
include "form.def";    // Form selectors
include "builtin.def"; // Builtin functions

//
// Enum string constants for international translation
// 
enum wrong_class = "Can't use FORM.GEN on non-form objects.  ",
      form_empty = "Form design was empty.  "
;
//

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 
     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
     display,    // Type of display screen we are on
     is_popup,   // POPUP validation requested
     pop_cnt,    // Counter used to indicate running popup id
     color;      // Color returned from getcolor function

 //-----------------------------------------------
 // Assign default values to some of the variables
 //-----------------------------------------------
 crlf = chr(10)
 temp = ""
 carry_flg = carry_first = carry_cnt = carry_len = carry_lent = 
 wnd_cnt = line_cnt =  color_flg = cnt = 0
 page_cnt = 1
 is_popup = 0

 screen_size()
 //-------------------------------
 // Create Format file
 //-------------------------------
 if !make_Fmt() then goto nogen

 header(); 
}

*-- Format file initialization code --------------------------------------------

IF SET("TALK") = "ON"
   SET TALK OFF
   lc_talk = "ON"
ELSE
   lc_talk = "OFF"
ENDIF
//lc_cursor = SET("CURSOR")
//SET CURSOR ON

*-- This form was created in {display_type()} mode
SET DISPLAY TO {display_type()}

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 nul2zero(ROW_POSITN) - line_cnt > scrn_size then 
      line_cnt = line_cnt + scrn_size + 1 
   endif
   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 + ",";
}

*-- Window for memo field {lower(FLD_FIELDNAME)}.
DEFINE WINDOW { Window_Def(flds)}\
{  endif
 next flds
 print(crlf);
 if carry_flg then 
}

lc_carry = SET("CARRY")
*-- Fields to carry forward during APPEND.
SET CARRY TO { Carry_Flds()}
{endif

     if check_for_popups() then
}
SET PROCEDURE TO u_{substr(name,1,6)}
DO s_{substr(name,1,6)}
{    endif}

*-- @ SAY GETS Processing. -----------------------------------------------------

*--  Format Page: {page_cnt}

{line_cnt = wnd_cnt = 0
 foreach ELEMENT k
   color = getcolor(FLD_DISPLAY, FLD_EDITABLE) // get color of element
   if nul2zero(ROW_POSITN) - line_cnt > scrn_size then
      line_cnt = line_cnt + scrn_size + 1;
      ++page_cnt;
}
READ

*-- Format Page: {page_cnt}

{  endif
//
   if ELEMENT_TYPE == @TEXT_ELEMENT or ELEMENT_TYPE == @FLD_ELEMENT then
     if FLD_FIELDTYPE == calc then}
*-- Calculated field: {lower(FLD_FIELDNAME)} - {FLD_DESCRIPT}
{    endif
     if FLD_FIELDTYPE == memvar then}
*-- Memory variable: {lower(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}
"{TEXT_ITEM}" \
{     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
               lower(temp + FLD_FIELDNAME)} \
{        endif
         if Ok_Template(k) then}
PICTURE "{  if FLD_PICFUN then}@{FLD_PICFUN}\
{             if AT("S", FLD_PICFUN) then}{FLD_PIC_SCROLL}{endif}\
 {//leave this space}\
{           endif
            if !AT("S", FLD_PICFUN) and !AT("M", FLD_PICFUN) then
               FLD_TEMPLATE}\
{           endif}" \
{        endif
      else // it's a get}
GET \
{        if FLD_FIELDTYPE == dbf then temp = "" else temp = "m->" endif
         lower(temp + 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 "{if FLD_PICFUN then}@{FLD_PICFUN}\
{           if AT("S", FLD_PICFUN) then}{FLD_PIC_SCROLL}{endif}\
 {//leave this space}\
{          endif
           if AT("M", FLD_PICFUN)}{FLD_PIC_CHOICE}{endif}\
{          if !AT("S", FLD_PICFUN) and !AT("M", FLD_PICFUN) then
              FLD_TEMPLATE}\
{          endif}" \
{        endif
         if FLD_L_BOUND or FLD_U_BOUND then color_flg = 1;}
;
   RANGE {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(FLD_OK_COND)) then
               // A POPUP is desired for showing coded values, redo the
               // VALID clause to call a UDF based on "U_" + Fld_fieldname
}
   VALID {get_udfname(FLD_FIELDNAME)}( {FLD_FIELDNAME} ) \
{
            else
}
   VALID {FLD_OK_COND} \
{
            endif

            if FLD_REJ_MSG then}
;
   ERROR \
{              if !AT("IIF", upper(FLD_HLP_MSG))}"{endif}{FLD_REJ_MSG}\
{              if !AT("IIF", upper(FLD_HLP_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;
}

*-- 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 lc_carry = "OFF"
  SET CARRY OFF
ENDIF
{endif}

//IF lc_cursor = "OFF"
//   SET CURSOR OFF
//ENDIF
{if wnd_names then}

RELEASE WINDOWS {substr(wnd_names, 1, (len(wnd_names) - 1))}
{endif}

IF lc_talk="ON"
   SET TALK ON
ENDIF

RELEASE {if carry_flg then}lc_carry,{endif}lc_talk,lc_fields,lc_status
{
     if is_popup then
}

DO c_{substr(name,1,6)}
SET PROCEDURE TO
{
     endif
}
*-- EOP: {filename(fmt_name)}FMT
{
// Create the Procedure File for POPUP's if required
     if is_popup then
          if not create(frame_path+"u_"+rtrim(substr(name,1,6))+".PRG") then
               pause(frame_path+"u_"+rtrim(substr(name,1,6))+".PRG" + 
                     read_only + any_key);
               goto nogen;
          endif
}
//
{print("*"+replicate("-",78)+crlf);}
*-- Name....: {frame_path}u_{rtrim(substr(name,1,6))}.PRG
*-- Date....: {ltrim(SUBSTR(date(),1,8))}
*-- Version.: dBASE IV, Procedure for Format {Frame_ver}.0
*-- Notes...: Procedure file for VALID POPUPs with {filename(fmt_name)}FMT
{print("*"+replicate("-",78)+crlf);}
//
PROCEDURE s_{substr(name,1,6)}  && Open files and Define POPUPs
{
          pop_cnt = 0;                      // Scan to create opens & defines
          foreach Fld_element flds
               if AT("POPUP", UPPER(FLD_OK_COND)) then
                    ++pop_cnt;
}
  DEFINE WINDOW {get_popname(FLD_OK_COND)} FROM 7,30 TO 9,{31+len(FLD_FIELDNAME)+len(FLD_TEMPLATE)+5}
//{ nmsg("Length of fld_name ") pause(str(len(FLD_FIELDNAME))))
// nmsg("Length of fld_length") pause(str(len(FLD_LENGTH)))}
  USE {get_file(FLD_OK_COND)} ORDER {get_key(FLD_OK_COND)} IN {pop_cnt+1} AGAIN

  DEFINE POPUP {get_popname(FLD_OK_COND)} FROM 10,40 ;
    PROMPT FIELD {get_field(FLD_OK_COND)} ;
    MESSAGE "Select from list using ENTER, cancel selection with ESC"
  ON SELECTION POPUP {get_popname(FLD_OK_COND)} DEACTIVATE POPUP

{
               endif
          next flds;
}
  SELECT 1

*-- EOP: s_{substr(name,1,6)}
RETURN

{print("*"+replicate("-",78)+crlf);}
PROCEDURE c_{substr(name,1,6)}  && Close files and Release POPUPs
{
          pop_cnt = 0;                      // Scan to close files and release
          foreach Fld_element flds
               if AT("POPUP", UPPER(FLD_OK_COND)) then
                    ++pop_cnt;
}
  USE IN {pop_cnt+1}

  RELEASE WINDOW {get_popname(FLD_OK_COND)}
  RELEASE POPUP {get_popname(FLD_OK_COND)}

{
               endif
          next flds;
}
  SELECT 1

*-- EOP: c_{substr(name,1,6)}
RETURN

{print("*"+replicate("-",78)+crlf);}
FUNCTION empty                && Determine if the passed argument is NULL
PARAMETER x
  mtype = TYPE("x")
  DO CASE
    CASE mtype = "C"
      retval = (LEN(TRIM(x))=0)
    CASE mtype$"NF"
      retval = (x=0)
    CASE mtype = "D"
      retval = (" "$DTOC(x))
  ENDCASE
*-- EOP: empty
RETURN (retval)

{
          pop_cnt = 0;
          foreach Fld_element flds
               if AT("POPUP", UPPER(FLD_OK_COND)) then
                    ++pop_cnt;
}
{print("*"+replicate("-",78)+crlf);}
FUNCTION {get_udfname(Fld_fieldname)}
PARAMETER fld_name

{
                    if !is_required(FLD_OK_COND) then
}
  IF empty(fld_name)                   && Not a required field, so return
    RETURN (.T.)                       && if null field
  ENDIF                                                

{
                    endif
}
  EscKey = 27                          && 27 represents the ESC key

  SELECT {pop_cnt+1}                       && Select the lookup file

  SEEK fld_name
  IF .NOT. FOUND()
    ACTIVATE WINDOW {get_popname(FLD_OK_COND)}
    ?? " {FLD_FIELDNAME} =", {FLD_FILENAME}->{FLD_FIELDNAME} \
{        if Ok_Template(flds) then}
PICTURE "{  if FLD_PICFUN then}@{FLD_PICFUN}\
{             if AT("S", FLD_PICFUN) then}{FLD_PIC_SCROLL}{endif}\
 {//leave this space}\
{           endif
            if !AT("S", FLD_PICFUN) and !AT("M", FLD_PICFUN) then
               FLD_TEMPLATE}\
{           endif}" \
{        endif}

    ACTIVATE SCREEN
    ACTIVATE POPUP {get_popname(FLD_OK_COND)}

    DEACTIVATE WINDOW {get_popname(FLD_OK_COND)}
    IF LASTKEY() <> EscKey 
      rtn_fld = PROMPT()
      @ {nul2zero(ROW_POSITN)},{nul2zero(COL_POSITN)} GET rtn_fld \
{        if Ok_Template(flds) then}
PICTURE "{  if FLD_PICFUN then}@{FLD_PICFUN}\
{             if AT("S", FLD_PICFUN) then}{FLD_PIC_SCROLL}{endif}\
 {//leave this space}\
{           endif
            if !AT("S", FLD_PICFUN) and !AT("M", FLD_PICFUN) then
               FLD_TEMPLATE}\
{           endif}" \
{        endif}

      CLEAR GETS
      DO CASE
        CASE TYPE("fld_name") = "C"
          REPLACE A->{get_field(FLD_OK_COND)} WITH rtn_fld
        CASE TYPE("fld_name") $ "NF"
          REPLACE A->{get_field(FLD_OK_COND)} WITH VAL(rtn_fld)
      ENDCASE
      SELECT 1
      RETURN (.T.)
    ELSE
      SELECT 1
{
                    if !is_required(FLD_OK_COND) then
}
      IF empty(fld_name)               && Not a required field, so return
        RETURN (.T.)                   && if null field
      ENDIF                                                

{
                    endif
}
      RETURN (.F.)
    ENDIF           

  ELSE
    SELECT 1
    RETURN (.T.)
  ENDIF

  SELECT 1                             && Go back to the edit file

*-- EOP: {get_udfname(Fld_fieldname)}
RETURN (.F.)

{
               endif
          next flds;
}
{print("*"+replicate("-",78)+crlf);}

{
          fileerase(frame_path+"u_"+rtrim(substr(name,1,6))+".DBO");
     endif;  // there were POPUP VALID clauses

 if cnt == 0 then
    pause(form_empty + any_key)
 endif
 fileerase(fmt_name+".FMO")
 nogen:
return 0;
//---------------------------------------
// Template user defined functions follow
//---------------------------------------

define header()
    // Print Header in program
    print( replicate( "*",80) + crlf);}
*-- Name.......: {filename(fmt_name)}FMT
*-- Date.......: {ltrim( substr( date(),1,8))}
*-- Version....: dBASE IV, Format {FRAME_VER}.1
*-- Notes......: Format files use "" as delimiters!
{   print( replicate( "*",80) + crlf);
enddef

//--------------------------------------------------------------
define ok_template(cur)
     var temp; temp = cur.FLD_TEMPLATE
     if cur.FLD_TEMPLATE && !(chr(cur.FLD_VALUE_TYPE) == "D" || 
                              chr(cur.FLD_VALUE_TYPE) == "M") then
        return 1;
     else
        return 0;
     endif
enddef

//--------------------------------------------------------------
define screen_size()
   // Test screen size if display > 2 screen is 43 lines
   display = numset(_flgcolor)
   if display > ega25 then scrn_size = 39 else scrn_size = 21 endif

   // Test to see if status was off before going into form designer
   dB_status = numset(_flgstatus)
   if scrn_size == 21 and !db_status then
      scrn_size = 24
   endif
   if scrn_size == 39 and !db_status then // status is off
      scrn_size = 42
   endif
   return;
enddef

//--------------------------------------------------------------
define display_type()
    var temp;
    case display of
       mono:   temp = "MONO"
       cga:    temp = "COLOR"
       ega25:  temp = "EGA25"
       mono43: temp = "MONO43"
       ega43:  temp = "EGA43"
     endcase
     return temp;
enddef

//--------------------------------------------------------------
define getcolor(f_display, f_editable)
 // 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, mchar)
   var result;
   // Output the of Box border and charater if any
   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)
   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)
   var result;
   result = nul2zero(cur.BOX_TOP) - line_cnt+","
   result = result + nul2zero(cur.BOX_LEFT)+" TO "
   temp = nul2zero(cur.BOX_TOP) + cur.BOX_HEIGHT - line_cnt - 1
   if temp > scrn_size then temp = scrn_size endif
   result = result + temp + "," + (nul2zero(cur.BOX_LEFT) + cur.BOX_WIDTH - 1)
   return result;
enddef 

//--------------------------------------------------------------
define Carry_Flds()
   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 = lower(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.
   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 nul2zero(numbr)
    // if number is nul and we are expecting a zero - convert the nul to 0
    if !numbr then numbr=0 endif
    return numbr;
enddef

//--------------------------------------------------------------
define check_for_popups()
foreach Fld_element flds
    if AT("POPUP", UPPER(FLD_OK_COND)) then
       is_popup = 1
       exit
    endif
next flds
return is_popup;
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 use_name;
enddef

//--------------------------------------------------------------
define get_key(valid_str)
     var  s_order,            // String "ORDER "
          at_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
          order_tag = substr(r_target, 1, at_space-1)
     endif
     return 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)
     if at_space == 0 then
          fld_name = r_target
     else
          fld_name = substr(r_target, 1, at_space-1)
     endif
     return fld_name;
enddef

//--------------------------------------------------------------
define get_popname(valid_str)
     var  pop_name;
     pop_name = "u_" + substr(get_field(valid_str),1,6);
     return pop_name;
enddef

//--------------------------------------------------------------
define get_udfname(fld_str)
     var  udf_name;
     udf_name = "u_" + substr(fld_str,1,6);
     return udf_name;
enddef

//--------------------------------------------------------------
define is_required(valid_str)
     var  req_flag;
     if AT("REQ",valid_str) then
          req_flag = 1
     else
          req_flag = 0
     endif
     return req_flag;
enddef
}
// EOP FORM.COD
------------------------------------------------------------------------------