home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CADKEY_C.ZIP / CADKEY14.ZIP / CDL / TBMAKE.CDL < prev    next >
Encoding:
Text File  |  1989-06-21  |  2.5 KB  |  105 lines
  1. REM ************************************************************************
  2. REM       Text template maker --- subroutine (tbmake.cdl)
  3.  
  4. REM    Purpose:  To have the user define all the fields, then write
  5. REM          the template description to an ASCII file
  6. REM ************************************************************************
  7.  
  8.  
  9.  
  10.    SET devout, $tplname
  11.    count = 0
  12.  
  13. :get_fldname
  14.    $fldname = " "
  15.    GETSTR "Enter field name:%s",$fldname,$fldname
  16.    ON (@KEY + 3) GOTO exit,exit,
  17.    CALL strlen, $fldname, lngth
  18.    IF (lngth > 8)
  19.       GOTO message3
  20.    IF (lngth == 0)
  21.       GOTO message4
  22.    CALL strcmp,$defstr,$fldname,match
  23.    IF (match == 0)
  24.       GOTO get_fldname
  25.  
  26. :ind_fldst
  27.    GETPOS  "Indicate field start position",def1
  28.    ON (@KEY + 3) GOTO exit,get_fldname,ind_fldst,
  29.    def1 = @KEY
  30.    fstx = @XVIEW
  31.    fsty = @YVIEW
  32.    dx = fstx - bpx
  33.    dy = fsty - bpy
  34.  
  35. :ind_fldnd
  36.    GETPOS  "Indicate field end position",def1
  37.    ON (@KEY + 3) GOTO exit,ind_fldst,ind_fldnd,
  38.    def1 = @KEY
  39.    fndx = @XVIEW
  40.    fndy = @YVIEW
  41.    IF (fndx < fstx)
  42.       GOTO message1
  43.    fldlngth = fndx - fstx
  44.  
  45. :text_ht
  46.    GETFLT  "Enter text hight (%f):",txtht,txtht
  47.    ON (@KEY + 3) GOTO exit,ind_fldnd,
  48.  
  49. :asp_rat
  50.    GETFLT  "Enter text aspect ratio (%f):",asprat,asprat
  51.    ON (@KEY + 3) GOTO exit,text_ht,
  52.  
  53. :font
  54.    GETINT  "Enter text font number (%d):",font,font,
  55.    ON (@KEY + 3) GOTO exit,asp_rat,
  56.  
  57. :pen
  58.    GETINT  "Enter pen number (%d):",pen,pen,
  59.    ON (@KEY + 3) GOTO exit,font,
  60.  
  61. :get_deftxt
  62.    nchar = floor((fndx - fstx) / (txtht * asprat))
  63.    SPRINT $str1, "Enter field default text. Max. %d char.",nchar
  64.    $str2 = ":%s"
  65.    CALL strcat, $str1, $str2
  66.  
  67.    GETSTR $str1, $defstr, $deftxt
  68.    ON (@KEY + 3) GOTO exit,pen,
  69.    CALL strlen, $deftxt, lngth
  70.    IF (lngth > nchar)
  71.       GOTO message2
  72.  
  73.    count = count + 1
  74.    PRINT "%d %s %d \"%s\" %.4f %.4f %.4f %.4f %.4f %d %d\n",count,$fldname,\
  75.           nchar,$deftxt,dx,dy,fldlngth,txtht,asprat,font,pen,
  76.    GOTO get_fldname
  77.  
  78. :message1
  79.    PROMPT "Field limits error... try again."
  80.    WAIT 2
  81.    GOTO ind_fldst
  82.  
  83. :message2
  84.    PROMPT "Too many characters ... try again."
  85.    WAIT 2
  86.    $deftxt = " "
  87.    GOTO get_deftxt
  88.  
  89. :message3
  90.    PROMPT "Too many characters ... try again."
  91.    WAIT 2
  92.    $deftxt = " "
  93.    GOTO get_fldname
  94.  
  95. :message4
  96.    PROMPT "Field must be named ... try again."
  97.    WAIT 2
  98.    $deftxt = " "
  99.    GOTO get_fldname
  100.  
  101. :exit
  102.    PRINT "10000 end 3 \"end\" 0 0 0 0 0 1 1"
  103.    CLOSE devout
  104.    EXIT
  105.