home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / graphics / weld12.zip / WELD12.LSP < prev    next >
Text File  |  1993-01-30  |  21KB  |  463 lines
  1. ;▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  2. ;▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  3. ;▓▓                                                                         ▓▓
  4. ;▓▓                      WRITTEN BY JIM COX 1-1-92                          ▓▓
  5. ;▓▓                                                                         ▓▓
  6. ;▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  7. ;▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  8. ;REMEMBER -- OSMODE & ORTHOMODE MUST BE TURNED OFF TO RUN PROGRAM.............
  9. ;▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  10. (defun dtr(ang)
  11.  (* pi (/ ang 180.0))
  12. );end of dtr
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;
  14. (defun err(s)
  15.   (setq *error* olderr  olderr nil)           ;restore original error function
  16.   (if (not (member s '("" "console break" "Function cancelled")))
  17.     (princ (strcat "\nError: " s))
  18.   ) 
  19.      (REDRAW)
  20.      (RESET)
  21.      (setq *error* OLD_ERR)
  22.      (princ)
  23. );err
  24. (defun set_var()
  25.  
  26.  (setq OLD_ERR *error* *error* err)
  27.  (setq old_cmdecho(getvar "cmdecho"))
  28.  (setvar "cmdecho" 0)
  29.  (setq old_dimasz (getvar"dimasz"))
  30.  (setq old_blip (getvar "blipmode"))
  31.  (setvar "blipmode" 0)
  32.  (setq old_osmode(getvar"osmode"))
  33.  (setvar"osmode" 0);<--------------must be 0 or program will crash
  34.  (setq old_ortho (getvar"orthomode"))
  35.  (setvar"orthomode" 0);<-----------must be 0
  36.  (setq plwd(getvar"plinewid"))
  37.  (setvar"plinewid" 0)
  38. );set_var
  39.  
  40. (defun reset()
  41.    (setvar"orthomode" old_ortho)
  42.    (setvar"dimasz" old_dimasz)
  43.    (setvar"osmode" old_osmode)
  44.    (setvar "cmdecho" old_cmdecho)
  45.    (setvar "blipmode" old_blip)
  46.    (setvar"plinewid" plwd)
  47.    (setq *error* OLD_ERR)
  48. );reset
  49.  
  50.  
  51. ;▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  52.  (defun c:weld12 (/ pt x y sz ct ydex ypnt ylist xdex xpnt xlist icon_no
  53.                 old_cmdecho old_blip  P1 P2 P2A P3 P4 P5 P6 P7 P8 P9
  54.                 P10 P11 P12 P13 P14 P15 P16 P17 RAD START_CROW_FT
  55.                 END_CROW_FT B ANS W_SYM P4FBS1 P4FBS2
  56.                 P4FBS3 P4BWS1 P4BWS1A P4BWS2 P4BWS3 P4BWS4 P4BWS5
  57.                 P4BWS6 BV1 BV2 BV3 CP1 CP2 TX_LOC TX_LOC1 IN_LINE
  58.                 JUST_TXT TX_FT TX_HGT OLD_ERR old_ortho old_osmode
  59.                 plwd a_r_c a_r_c_1 TEST);add more
  60.  
  61. ;get popslide
  62.  (set_var)
  63.  (command"vslide" "weld12.sld")
  64.  
  65.   ;  Select choice
  66.   (setq y (getvar "viewsize")
  67.        ct (getvar"viewctr")
  68.        x  (* y 1.3752265)
  69.        pt (getpoint "\nSelect Icon Choice: ")
  70.     ylist (- (cadr ct) (/ y 2.0))
  71.      ypnt (- (cadr pt) ylist)
  72.      ydex (fix (/ ypnt (/ y 6.0)));number of squares y direction
  73.     xlist (- (car ct) (/ x 2.0))
  74.      xpnt (- (car pt) xlist)
  75.      xdex (fix (/ xpnt (/ x 8.0)));number of squares x direction
  76.   )
  77.   (setq icon_no (+ xdex (* (+ ydex 7) ydex)));<----- call function or
  78. ;<--------------command at this point
  79. (cond
  80.  ((<= icon_no 7)(acad_helpdlg "weld12" "")(setq W_SYM "HELP"))
  81.  ((= icon_no 8 )(setq W_SYM "FS"))
  82.  ((= icon_no 9)(setq W_SYM "FS"))
  83.  ((= icon_no 10)(setq W_SYM "FD"))
  84.  ((= icon_no 11)(setq W_SYM "FSA"))
  85.  ((= icon_no 12)(setq W_SYM "FDA"))
  86.  ((= icon_no 13)(setq W_SYM "FSAF"))
  87.  ((= icon_no 14)(setq W_SYM "FDAF"))
  88.  ((= icon_no 15)(setq W_SYM "STITCHA"))
  89.  ((= icon_no 18)(setq W_SYM "FBS"))
  90.  ((= icon_no 19)(setq W_SYM "FBS"))
  91.  ((= icon_no 20)(setq W_SYM "FBD"))
  92.  ((= icon_no 21)(setq W_SYM "FBSA"))
  93.  ((= icon_no 22)(setq W_SYM "FBDA"))
  94.  ((= icon_no 23)(setq W_SYM "FBSAF"))
  95.  ((= icon_no 24)(setq W_SYM "FBDAF"))
  96.  ((= icon_no 25)(setq W_SYM "C:WTEXT")(setq TEST "end"))
  97.  ((= icon_no 30)(setq W_SYM "BVS"))
  98.  ((= icon_no 31)(setq W_SYM "BVS"))
  99.  ((= icon_no 32)(setq W_SYM "BVD"))
  100.  ((= icon_no 33)(setq W_SYM "BVSA"))
  101.  ((= icon_no 34)(setq W_SYM "BVDA"))
  102.  ((= icon_no 35)(setq W_SYM "BVSAF"))
  103.  ((= icon_no 36)(setq W_SYM "BVDAF"))
  104.  ((= icon_no 37)(setq W_SYM "A"))
  105.  ((= icon_no 44)(setq W_SYM "BVVS"))
  106.  ((= icon_no 45)(setq W_SYM "BVVS"))
  107.  ((= icon_no 46)(setq W_SYM "BVVD"))
  108.  ((= icon_no 47)(setq W_SYM "BVVSA"))
  109.  ((= icon_no 48)(setq W_SYM "BVVDA"))
  110.  ((= icon_no 49)(setq W_SYM "BVVSAF"))
  111.  ((= icon_no 50)(setq W_SYM "BVVDAF"))
  112.  ((= icon_no 51)(setq W_SYM "AF"))
  113.  ((= icon_no 60)(setq W_SYM "BWS"))
  114.  ((= icon_no 61)(setq W_SYM "BWS"))
  115.  ((= icon_no 62)(setq W_SYM "BWD"))
  116.  ((= icon_no 63)(setq W_SYM "BWSA"))
  117.  ((= icon_no 64)(setq W_SYM "BWDA"))
  118.  ((= icon_no 65)(setq W_SYM "BWSAF"))
  119.  ((= icon_no 66)(setq W_SYM "BWDAF"))
  120.  ((= icon_no 67)(setq W_SYM "Q"))<-------leader only
  121. );cond
  122. (princ "\nYou choose icon ")(princ W_SYM)
  123. ;(princ icon_no)<---------------------------for my info only
  124. (redraw);<--------------------clears slide from screen.
  125. ;▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  126. ;                  ****MAIN****
  127.  
  128.    (if (= W_SYM "C:WTEXT")(C:WTEXT))
  129.    (if (/= TEST "end")(progn
  130.    (if (> icon_no 7)(progn
  131.  
  132.  
  133.    (setq DS(getvar"dimscale"))
  134.    (setq DT(getvar"dimtxt"))
  135.    (if (> DT DS)(progn(setq DS (/ DT 0.18))
  136.    (setvar "dimasz"  DT )));<--set arrow & symbol size
  137.  
  138.  
  139.    (setq P1(getpoint"\nFrom point "))
  140.    (setq P2(getpoint P1 "\nTo point "))
  141.    (command"dim1" "leader" P1 P2 ^c^c)
  142.    (if (= W_SYM "Q")
  143.    (progn ;<--------leader only
  144.     (while
  145.  
  146.       (setq P2A(getpoint P2))(command"line" P2 P2A "")
  147.       (setq P2(getvar"lastpoint"))))
  148.  
  149.    (progn ;<--------runs rest of program
  150.  
  151.    (while(setq P2A(getpoint P2))(setq P1 P2)(command"line" P2 P2A "")
  152.     (setq P2(getvar"lastpoint")))
  153.  
  154.        (if(<= (car P2)(car P1))(setq B(* -1.5 DS))
  155.                                (setq B(* 1.5 DS)));if
  156.  
  157.       (setq P3 (list (+ (car P2) B) (cadr P2)));end point of leader
  158.       (setq P4 (list (+ (car P2) (/ B 2))(cadr P2)));mid point of leader
  159.       (command"line" P2 P3 "")
  160. ;***************weld12 sym drawing points********************
  161.    (setq P5 (polar P4 (dtr 270) (* DS 0.25)));fs,bws,bvs
  162.    (setq P6 (polar P5 (dtr 45) (* DS 0.353)));fs,
  163.    (setq P7 (polar p4 (dtr 315)(* DS 0.353)));fs,fbs,bws,bvs,bvvs
  164.    (setq P8 (polar p4 (dtr 270)(* DS 0.75)));fbs
  165.    (setq P9 (polar P8 (dtr 45)(* DS 0.353)));fbs
  166.    (setq P10(polar P9 (dtr 180)(* DS 0.25)));fbs
  167.    (setq P11(polar P4 (dtr 0.0)(* DS 0.125)));bws
  168.    (setq P12(polar P11 (dtr 270) (* DS 0.25)));bws
  169.    (setq P13(polar P2 (dtr 90)(* DS 0.75)));field weld start
  170.    (setq P14(polar P13(dtr 315)(* DS 0.176)));field weld
  171.    (setq P15(polar P14(dtr 180)(* DS 0.125)));field weld end
  172.    (setq P16(polar P4 (dtr 307.5)(* DS 0.353)));bvvs
  173.    (setq P17(polar p4 (dtr 232.5)(* DS 0.353)));bvvs
  174.    (setq RAD(* DS 0.09375));all around symbol, circle
  175. ;****************************arcs***************************
  176.    (setq P4FBS1(polar P4 (dtr 180)(* DS 0.0625)));<-- fbs,bvs,bvvs,start arc
  177.    (setq P4FBS2(polar P4 (dtr 90)(* DS 0.0625)));<----fbs,bvs,bvvs,mid arc
  178.    (setq P4FBS3(polar P4 (dtr 0.0)(* DS 0.0625)));<-- fbs,bvs,bvvs,end arc
  179.    (setq P4BWS1(polar P4 (dtr 180)(* DS 0.0625)))
  180.    (setq P4BWS1A(polar P4 (dtr 0.0)(* DS 0.125)))
  181.    (setq P4BWS2(polar P4BWS1A (dtr 90)(* DS 0.125)))
  182.    (setq P4BWS3 (polar P4(dtr 0.0)(* DS 0.1875)))
  183.    (setq P4BWS4 (polar P4BWS1(dtr 270)(* DS 0.25)))
  184.    (setq P4BWS5 (polar P4BWS3(dtr 270)(* DS 0.3125)))
  185.    (setq P4BWS6 (polar P4BWS3(dtr 270)(* DS 0.25)))
  186.    (setq BV1(polar P4 (dtr 270)(* DS 0.375)));<-------- bvs,bvvs arc
  187.    (setq BV2(polar P4 (dtr 310)(* DS 0.4)));<-------bvs,bvvs arc
  188.    (setq BV3(polar P4 (dtr 230)(* DS 0.4)));<-------bvs,bvvs arc
  189.    (setq CP1(polar P4 (dtr 128)(* DS 0.5)));<------mirror window
  190.    (setq CP2(polar P4 (dtr 308)(* DS 1.0)));<------mirror window
  191. ;**************************draw weld symbols***************************
  192.    (cond
  193.     ((= (substr W_SYM 1 2) "FS") (command"pline" P4 P5 P6 ""))
  194.     ((= (substr W_SYM 1 2) "FD") (command"pline" P4 P5 P6 "")
  195.                                  (command"mirror" "w" CP1 CP2 "" P2 P3 "N"))
  196.     ((= (substr W_SYM 1 7) "STITCHA") (command"pline" P4 P5 P6 "")
  197.                                  (command"mirror" "w" CP1 CP2 "" P2 P3 "N")
  198.                                  (command"move" P5 "" P4 P6 ))
  199.     ((= (substr W_SYM 1 3) "FBS")(command"pline" P7 P4 P8 P9 P10 "")
  200.                                  (command"arc" P4FBS1 P4FBS2 P4FBS3)
  201.                                  (setq a_r_c(entlast)));arc
  202.     ((= (substr W_SYM 1 3) "FBD")(command"pline" P7 P4 P8 P9 P10 "")
  203.                                  (command"mirror" "w" CP1 CP2 "" P2 P3 "N"))
  204.     ((= (substr W_SYM 1 3) "BWS")(command"pline" P5 P4 P11 P12 "")
  205.                                  (command"arc" P4BWS1 P4BWS2 P4BWS3);*arc
  206.                                  (setq a_r_c(entlast))
  207.                                  (command"arc" P4BWS4 P4BWS5 P4BWS6));*arc
  208.     ((= (substr W_SYM 1 3) "BWD")(command"pline" P5 P4 P11 P12 "")
  209.                                  (command"arc"  P4BWS4 P4BWS5 P4BWS6);*arc
  210.                             (command"mirror" "w" CP1 CP2 "" P2 P3 "N"))
  211.     ((= (substr W_SYM 1 3) "BVS")(command"pline" P7 P4 P5 "")
  212.                                  (command"arc" P4FBS1 P4FBS2 P4FBS3);*arc
  213.                                  (setq a_r_c(entlast))
  214.                                  (command"arc" "c" P4 BV1 BV2));*arc
  215.     ((= (substr W_SYM 1 3) "BVD")(command"pline" P7 P4 P5 "")
  216.                                  (command"arc" "c" P4 BV1 BV2);*arc
  217.                                  (command"mirror" "w" CP1 CP2 "" P2 P3 "N"))
  218.     ((= (substr W_SYM 1 4) "BVVS")(command"pline" P16 P4 P17 "")
  219.                                   (command"arc" "c" P4 BV3 BV2);arc
  220.                                   (command"arc" P4FBS1 P4FBS2 P4FBS3)
  221.                                   (setq a_r_c(entlast)));arc
  222.     ((= (substr W_SYM 1 4) "BVVD")(command"pline" P16 P4 P17 "")
  223.                                   (command"arc" "c" P4 BV3 BV2)
  224.                                   (command"mirror" "w" CP1 CP2 "" P2 P3 "N"))
  225.    );cond
  226. ;********************crows foot**************************
  227.     (if(<=(car P2)(car P1))
  228.     (progn
  229.     (setq START_CROW_FT (polar P3(dtr 120)(* 0.375 DS)))
  230.     (setq END_CROW_FT (polar P3(dtr 240)(* 0.375 DS)))
  231.     (command"pline" START_CROW_FT P3 END_CROW_FT ""));progn
  232.  
  233.     (progn
  234.     (setq START_CROW_FT(polar P3(dtr 60)(* 0.375 DS)))
  235.     (setq END_CROW_FT(polar P3(dtr 300)(* 0.375 DS)))
  236.     (command"pline" START_CROW_FT P3 END_CROW_FT "")));progn,if
  237. ;*******************all around weld sym & field sym************************
  238.     (if(wcmatch W_SYM "*A*")(command"circle" P2 RAD));if
  239.     (if(wcmatch W_SYM "*AF*")(progn
  240.           (command"circle" P2 RAD)
  241.           (command"pline" P2 P13 P14 P15 "")
  242.           (command"solid" P15 P14 P13 "" "")));progn,if
  243.  
  244.     (if(= (substr W_SYM(strlen W_SYM))"F")(progn
  245.           (command"pline" P2 P13 P14 P15 "")
  246.           (command"solid" P15 P14 P13  "" "")));progn,if
  247. ;*********************weld sym on far side question********************
  248.     (if(wcmatch W_SYM "*S*")
  249.     (setq ANS(strcase(getstring "\nLocate weld on far side < N >: "))));if
  250.     (if (= ANS "Y")
  251.      (progn
  252.       (command"mirror" "w" CP1 CP2 "" P2 P3 "Y")<----mirror all
  253.      (if (/= W_SYM "STITCHA")(progn
  254.       (command"vslide" "weld12.sld")
  255.       (prompt"\nEnter FS FBS BWS BVS BVVS to add another weld to the near side. ")
  256.       (setq W_SYM (strcase(getstring"\nEnter one of the above or < cr > : ")))
  257.       (if (and (/= W_SYM "")(/= W_SYM "N")(/= a_r_c nil))(progn
  258.           (entdel a_r_c)(setq a_r_c nil)));if,progn,small arc
  259.  
  260.       (cond
  261.        ((= (substr W_SYM 1 2) "FS") (command"pline" P4 P5 P6 ""))
  262.        ((= (substr W_SYM 1 3) "FBS")(command"pline" P7 P4 P8 P9 P10 ""))
  263.        ((= (substr W_SYM 1 3) "BWS")(command"pline" P5 P4 P11 P12 "")
  264.                                  (command"arc" P4BWS4 P4BWS5 P4BWS6)
  265.                                  (setq a_r_c_1(entlast)));*arc
  266.        ((= (substr W_SYM 1 3) "BVS")(command"pline" P7 P4 P5 "")
  267.                                  (command"arc" "c" P4 BV1 BV2)
  268.                                  (setq a_r_c_1(entlast)));*arc
  269.        ((= (substr W_SYM 1 4) "BVVS")(command"pline" P16 P4 P17 "")
  270.                                     (command"arc" "c" P4 BV3 BV2)
  271.                                     (setq a_r_c_1(entlast)));arc
  272.       );cond
  273.       (redraw)
  274.       ));if,progn /=stitcha
  275.    ));progn,if ans = Y
  276. <------------------------melt thru************************************
  277.   (if (/= a_r_c nil)
  278.   (progn
  279.    (setq MELT_THRU(strcase(getstring"\nDo you wish a melt thru < N > ")))
  280.    (if (= MELT_THRU "Y")
  281.       (progn
  282.         (setq sz(* DS 0.08))
  283.         (command"pedit" a_r_c "y" "w" sz "")
  284.       ));if progn
  285.   ));if progn
  286.  
  287.  
  288.  (setq TXT(strcase(getstring"\nEnter Y for weld size or < cr >to cancel ")))
  289.  (if(= TXT "Y")
  290.   (progn
  291.  
  292. (if(<= (car P2)(car P1))
  293.      (progn
  294.       (setq TX_FT(polar P3(dtr 135)(* DS 0.5)))
  295.       (setq JUST_TXT "R")
  296.      );progn
  297.      (progn
  298.      (setq TX_FT(polar P3(dtr 45)(* DS 0.5)))
  299.      (setq JUST_TXT "L")
  300.      )
  301.    );if
  302.  
  303.    (setq TX_HGT(* DS 0.125))
  304.    (setq TX_LOC (polar P4(dtr 180)(* DS 0.0625)))
  305.    
  306.    (setq IN_LINE(getstring 1 "\nEnter ns weld #1 or < cr > "))
  307.    (setq TX_LOC1(polar TX_LOC(dtr 270)(* DS 0.25)))
  308.    (command "text" "J" "R" TX_LOC1 TX_HGT 0 IN_LINE)
  309.  
  310.    (setq IN_LINE(getstring 1 "\nEnter ns weld #2 or < cr > "))
  311.    (setq TX_LOC1(polar TX_LOC(dtr 270)(* DS 0.75)))
  312.    (command "text" "J" "R" TX_LOC1 TX_HGT 0 IN_LINE)
  313.  
  314.    (setq IN_LINE(getstring 1 "\nEnter fs weld #1 or < cr > "))
  315.    (setq TX_LOC1(polar TX_LOC(dtr 90)(* DS 0.0625)))
  316.    (command "text" "J" "R" TX_LOC1 TX_HGT 0 IN_LINE)
  317.  
  318.    (setq IN_LINE(getstring 1 "\nEnter fs weld #2 or < cr > "))
  319.    (setq TX_LOC1(polar TX_LOC(dtr 90)(* DS 0.5)))
  320.    (command "text" "J" "R" TX_LOC1 TX_HGT 0 IN_LINE)
  321.  
  322.    (prompt"\rEnter text for crows foot  or < cr > ")
  323.    (if (= JUST_TXT "R")
  324.     (command"dtext" "J" JUST_TXT TX_FT TX_HGT 0 "")
  325.     (command"dtext" TX_FT TX_HGT 0)
  326.    );if
  327.  
  328.   );progn
  329.  );if
  330.  
  331. ));if,progn /= "Q";<-------------leader only
  332. ));ends if and progn for /= 0
  333. ));progn if /= end
  334. (reset);reset all functions
  335.  
  336. (princ)
  337. );* end weld12 function
  338. ;▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓END OF WELD12 PROGRAM▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  339. ;code lock=┘ô2*ö«   rem setq codelock for 30 day demos.
  340. ;* CHGERR restores the original function of the keys if the program aborts.
  341. (defun chgerr (s)                     
  342.   (setq *error* olderr  olderr nil)           ;restore original error function
  343.   (if (not (member s '("" "console break" "Function cancelled")))
  344.     (princ (strcat "\nError: " s))
  345.   ) 
  346.   (setvar "BLIPMODE" blip)
  347.   (textscr)
  348.   (setvar "CMDECHO" cmdech)
  349.   (prompt "\e[0;75;0;75p")                    ;restore left arrow
  350.   (prompt "\e[0;77;0;77p")                    ;restore right arrow
  351.   (prompt "\e[0;59;0;59p")                    ;restore <F1>
  352.   (prompt "\e[0;82;0;82p")                    ;restore <INS>
  353.   (prompt "\e[0;71;0;71p")                    ;restore <HOME>
  354.   (prompt "\e[0;79;0;79p")                    ;restore <END>
  355.   (prompt "\e[0;73;0;73p")                    ;restore <PG UP>
  356.   (prompt "\e[0;81;0;81p")                    ;restore <PG DN>
  357.   (prompt "\e[0;72;0;72p")                    ;restore <UP>
  358.   (prompt "\e[0;80;0;80p")                    ;restore <DN>
  359.   (graphscr)
  360.   (if (/= "" s)
  361.       (foreach s '(entity txt test txtlen curpos key blip cmdech) (set s nil))
  362.   )
  363.   (princ)
  364. );defun chgerr
  365.  
  366. (defun C:WTEXT (/ entity txt test txtlen curpos key)
  367.   (setq olderr *error*                        ;initialize variables
  368.         *error* chgerr
  369.         key 0                                 ;zero out key
  370.         cmdech (getvar "CMDECHO")
  371.         blip   (getvar "BLIPMODE")
  372.   )
  373.   (setvar "CMDECHO" 0)                        ;turn echo off
  374.   (setvar "BLIPMODE" 0)                       ;turn blips off
  375.   (setq entity                                ;gets edata
  376.         (entget (car (while (not entity) (setq entity   ;while ensures entity selection
  377.                                                (entsel "\nPick text to edit: ")
  378.   )     )       )    )                   )
  379.   (if (= "TEXT" (setq test (cdr (assoc 0 entity))))     ;test if text was selected
  380.     (progn                                    ;then 
  381.       (setq txt (cdr (assoc 1 entity))        ;get text string
  382.             txtlen (1+ (strlen txt))          ;get text length
  383.             curpos 1                          ;initial cursor position=length
  384.       )
  385.       (textscr)                     ;go to text screen
  386.       (prompt "\e[0;75;0;115p")     ;change left arrow key to <ctrl left>
  387.       (prompt "\e[0;77;0;116p")     ;change right arrow key to <ctrl right>
  388.       (prompt "\e[0;59;0;3p")       ;change <F1> to nul
  389.       (prompt "\e[0;82;0;3p")       ;change <INS> to nul
  390.       (prompt "\e[0;71;0;3p")       ;change <HOME> to nul
  391.       (prompt "\e[0;79;0;3p")       ;change <END> to nul
  392.       (prompt "\e[0;73;0;3p")       ;change <PG UP> to nul
  393.       (prompt "\e[0;81;0;3p")       ;change <PG DN> to nul
  394.       (prompt "\e[0;72;0;3p")       ;change <UP> to nul
  395.       (prompt "\e[0;80;0;3p")       ;change <DN> to nul
  396.       (prompt "\e[2J")              ;clear screen and place header
  397.       (prompt
  398.  "\e[7;1;37;44m                            Weld Symbol Editor                                       "
  399.       )
  400.       (prompt
  401.   "\e[2;1H                                                                                "
  402.       )
  403.       (prompt
  404.  "\e[3;1H        use  <LEFT>  <RIGHT>  <DEL>  <BACKSPACE>  or type to insert text        "
  405.       )
  406.       (prompt "\e[0;37;40m")                  ;sets ansi screen to normal
  407.       (prompt "\e[8;1HEdit text:")            ;print title
  408.       (prompt "\e[1m")                        ;bold
  409.       (prompt "\e[m")                         ;normal
  410.       (prompt (strcat "\e[10;1H" txt))
  411.       (prompt "\r")
  412.       (while (/= key 13)                      ;while key is not return <enter> key
  413.         (prompt (strcat "\e[10;" (itoa curpos) "H")) ;initial cursor position
  414.         (setq key (last (grread)))
  415.         (cond
  416.           ( (= key 243)                       ;<ctrl left> arrow
  417.             (setq curpos (1- curpos))
  418.             (if (< curpos 1) (setq curpos txtlen))
  419.           )
  420.           ( (= key 244)                       ;<ctrl right> arrow
  421.             (setq curpos (1+ curpos))
  422.             (if (> curpos txtlen) (setq curpos 1))
  423.           )
  424.           ( (= key 211)                       ;if key was del
  425.             (setq txt (strcat (substr txt 1 (1- curpos)) (substr txt (1+ curpos))))
  426.             (setq txtlen (1+ (strlen txt)))   ;get new text length
  427.             (prompt (strcat "\e[10;1H" txt " "))     ;display txt string
  428.           )
  429.           ( (and (= key 8) (> curpos 1))             ;delete back arrow key
  430.             (setq curpos (1- curpos))
  431.             (setq txt (strcat (substr txt 1 (1- curpos)) (substr txt (1+ curpos))))
  432.             (setq txtlen (1+ (strlen txt)))          ;get new text length
  433.             (prompt (strcat "\e[10;1H" txt " "))     ; display txt string
  434.           )
  435.           ( (and (> key 31) (< key 127))             ;if valid char key . . .
  436.             ;create new text string including the new character at the cursor position
  437.             (setq txt (strcat (substr txt 1 (1- curpos)) (chr key) (substr txt curpos)))
  438.             (setq txtlen (1+ (strlen txt)))          ;get new text length
  439.             (setq curpos (1+ curpos))                ;get new cursor position
  440.             (prompt (strcat "\e[10;1H" txt " "))     ;display new text string
  441.           )
  442.           (t nil)
  443.         );cond
  444.       );while
  445.       (chgerr "")
  446.       (prompt "\e[2J")
  447.       (prompt "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n") ;clear screen
  448.       (setq entity (subst (cons 1 txt) (assoc 1 entity) entity))    ;change entity list
  449.       (entmod entity)                         ;update entity
  450.     );progn
  451.     (prompt "\nEntity was not text.")         ;print bad pick message
  452.   );if
  453.   (if (= "TEXT" test)
  454.     (prompt "\n\t\n\t\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n") ;clear screen
  455.   );if text
  456.   (princ)
  457. );defun C:WTEXT
  458.  
  459. (princ)
  460. ;*end of WTEXT.LSP file
  461. ;▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓END OF PROGRAM▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
  462.  
  463.