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 / TBAPPND.CDL < prev    next >
Encoding:
Text File  |  1989-06-21  |  3.3 KB  |  154 lines
  1. REM ************************************************************************
  2. REM       Text template maker --- subroutine (tbappnd.cdl)
  3.  
  4. REM    Purpose:  To append fields to an existing template file.
  5. REM ************************************************************************
  6.  
  7.  
  8. :set_devin
  9.    SET devin, $tplname
  10.    SET devout, tpf
  11.  
  12.    count = 0
  13.  
  14. :read_fld
  15.    INPUT "%d %s %d",sqnum,$tmp,nchar
  16.  
  17.    CLEAR    $fldtxt
  18.    ARRAY    $fldtxt[nchar+1]
  19.  
  20. REM   *** dummy read two characters
  21.    INPUT "%c %c",$fldtxt[0],$fldtxt[1]
  22.  
  23.    i = 0
  24. :txtloop
  25.    INPUT "%c",$fldtxt[i]
  26.    IF ($fldtxt[i] == 34)
  27.       GOTO read_more
  28.    i = i + 1
  29.    goto txtloop
  30.  
  31. :read_more
  32.    $fldtxt[i] = 0
  33.    INPUT "%f %f %f %f %f %d %d\n",dx,dy,fldlngth,txtht,asprat,font,pen
  34.  
  35.    IF (sqnum != 10000)
  36.       GOTO write_fld
  37.    GOTO more_fld
  38.  
  39. :write_fld
  40.    PRINT "%d %s %d \"%s\" %.4f %.4f %.4f %.4f %.4f %d %d\n",sqnum,$tmp,\
  41.           nchar,$fldtxt,dx,dy,fldlngth,txtht,asprat,font,pen
  42.    count = count + 1
  43.    GOTO read_fld
  44.  
  45. :more_fld
  46.    makeflg = 1
  47.    txtht = @dimht
  48.    asprat = @txtasp
  49.    pen = @pen
  50.    font = 1
  51.    def1 = 1
  52.    def3 = 3
  53.  
  54. :get_fldname
  55.    $fldname = " "
  56.    GETSTR "Enter field name:%s",$fldname,$fldname
  57.    ON (@KEY + 3) GOTO exit,exit,
  58.    CALL strlen, $fldname, lngth
  59.    IF (lngth > 8)
  60.       GOTO message3
  61.    IF (lngth == 0)
  62.       GOTO message4
  63.  
  64.    CALL strcmp,$defstr,$fldname,match
  65.    IF (match == 0)
  66.       GOTO get_fldname
  67.  
  68. :ind_fldst
  69.    GETPOS  "Indicate field start position",def1
  70.    ON (@KEY + 3) GOTO exit,get_fldname,ind_fldst,
  71.    def1 = @KEY
  72.    fstx = @XVIEW
  73.    fsty = @YVIEW
  74.    dx = fstx - bpx
  75.    dy = fsty - bpy
  76.  
  77. :ind_fldnd
  78.    GETPOS  "Indicate field end position",def1
  79.    ON (@KEY + 3) GOTO exit,ind_fldst,ind_fldnd,
  80.    def1 = @KEY
  81.    fndx = @XVIEW
  82.    fndy = @YVIEW
  83.    IF (fndx < fstx)
  84.       GOTO message1
  85.    fldlngth = fndx - fstx
  86.  
  87. :text_ht
  88.    GETFLT  "Enter text hight (%f):",txtht,txtht
  89.    ON (@KEY + 3) GOTO exit,ind_fldnd,
  90.  
  91. :asp_rat
  92.    GETFLT  "Enter text aspect ratio (%f):",asprat,asprat
  93.    ON (@KEY + 3) GOTO exit,text_ht,
  94.  
  95. :font
  96.    GETINT  "Enter text font number (%d):",font,font,
  97.    ON (@KEY + 3) GOTO exit,asp_rat,
  98.  
  99. :pen
  100.    GETINT  "Enter pen number (%d):",pen,pen,
  101.    ON (@KEY + 3) GOTO exit,font,
  102.  
  103. :get_deftxt
  104.    nchar = floor((fndx - fstx) / (txtht * asprat))
  105.    SPRINT $str1, "Enter field default text. Max. %d char.",nchar
  106.    $str2 = ":%s"
  107.    CALL strcat, $str1, $str2
  108.  
  109.    GETSTR $str1, $defstr, $deftxt
  110.    ON (@KEY + 3) GOTO exit,pen,
  111.    CALL strlen, $deftxt, lngth
  112.    IF (lngth > nchar)
  113.       GOTO message2
  114.  
  115.    count = count + 1
  116.    PRINT "%d %s %d \"%s\" %.4f %.4f %.4f %.4f %.4f %d %d\n",count,$fldname,\
  117.           nchar,$deftxt,dx,dy,fldlngth,txtht,asprat,font,pen,
  118.    GOTO get_fldname
  119.  
  120. :message1
  121.    PROMPT "Field limits error... try again."
  122.    WAIT 2
  123.    GOTO ind_fldst
  124.  
  125. :message2
  126.    PROMPT "Too many characters ... try again."
  127.    WAIT 2
  128.    $deftxt = " "
  129.    GOTO get_deftxt
  130.  
  131. :message3
  132.    PROMPT "Too many characters ... try again."
  133.    WAIT 2
  134.    $deftxt = " "
  135.    GOTO get_fldname
  136.  
  137. :message4
  138.    PROMPT "Field must be named ... try again."
  139.    WAIT 2
  140.    $deftxt = " "
  141.    GOTO get_fldname
  142.  
  143.  
  144. :exit
  145.    PRINT "10000 end 3 \"end\" 0 0 0 0 0 1 1"
  146.    CLOSE devout
  147.    CLOSE devin
  148.    SPRINT $cmd,"copy tpf %s",$tplname
  149.    EXEC 1, $cmd
  150.    EXEC 1, "del tpf"
  151.  
  152.    EXIT
  153.  
  154.