home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / LTOPL.LSP < prev    next >
Encoding:
Text File  |  1992-01-28  |  3.7 KB  |  107 lines
  1. (vmon)
  2.  
  3. (defun toperr(s)
  4.    (if (/= s "Function cancelled")
  5.        (princ (strcat "\nError:" s))
  6.    )
  7.    (setvar "CMDECHO" 1)
  8.    (setvar "HIGHLIGHT" 1)
  9.    (setq *error* oer)
  10.    (princ)
  11. )
  12.  
  13. (defun C:LTOPL(/ x oer ss ssl n p1 p2 p3 p4 sn en ename entn entn0 entl ss1 snn enn lw area1 area2)
  14.    (setvar "CMDECHO" 0)
  15.    (setvar "HIGHLIGHT" 0)
  16.    (setq oer *error* *error* toperr)
  17.    (princ "╒█╧▀┐φ╢╚ <")
  18.    (princ (setq lw (/ (getvar "TRACEWID") bl)))
  19.    (setq lw (if (null (setq x (getreal ">:"))) lw x))
  20.    (setvar "TRACEWID" (* lw bl))
  21.    (setq ss (ssget))
  22.     (setq ss1 (ssadd))
  23.    (if ss (progn (setq ssl (sslength ss) n 0)
  24.    (setq entl (entlast))
  25.    (repeat ssl
  26.       (setq sn (ssname ss n) en (entget sn))
  27.       (if en (progn
  28.          (if (and (member (substr (cdr (assoc 8 en)) 1 5) '("PWALL" "PWIND")) (member (setq ename (cdr (assoc 0 en))) '("LINE" "ARC")))
  29.              (progn
  30.              (if (= "LINE" ename) (progn
  31.              (command "pedit" sn "y" "")
  32.              (setq entl (entlast))
  33.              (command "pedit" entl "j" ss "" "")
  34.              (if (setq entn (entlast)) (setq entl entn))
  35.              (ltoplsub)
  36.              )
  37.              (progn
  38.              (setq ss1 (ssadd sn ss1))
  39.              ))
  40.              )
  41.              (progn
  42.              (if (and (member (substr (cdr (assoc 8 en)) 1 5) '("PWALL" "PWIND")) (= "POLYLINE" (cdr (assoc 0 en))))
  43.                  (progn
  44.                  (setq entl sn)
  45.                  (ltoplsub)
  46.                  ))
  47.              )
  48.         )
  49.              ) ;endprogn en
  50.        );endif
  51.     (setq n (1+ n))
  52.     )
  53.   ))
  54.    (if ss1 (progn
  55.        (setq entl (entlast))
  56.        (setq ssl (sslength ss1) n 0)
  57.        (repeat ssl
  58.           (setq sn (ssname ss1 n) en (entget sn))
  59.           (if en (progn
  60.              (command "pedit" sn "y" "")
  61.              (setq entl (entlast))
  62.              (command "pedit" entl "j" ss1 "" "")
  63.              (if (setq entn (entlast)) (setq entl entn))
  64.              (atoplsub)
  65.              )
  66.         )
  67.       (setq n (1+ n))
  68.       )
  69.       ))
  70.    (setvar "CMDECHO" 1)
  71.    (setvar "HIGHLIGHT" 1)
  72.    (setq *error* oer)
  73.    (princ)
  74. )
  75.  
  76. (defun ltoplsub()
  77.              (setq enn (entget (setq snn (entnext entl))) p1 (cdr (assoc 10 enn)))
  78.              (setq p2 (cdr (assoc 10 (entget (entnext snn)))))
  79.              (setq p3 (polar p1 (+ (angle p1 p2) 1.57079) 50))
  80.              (setq p4 (polar p1 (- (angle p1 p2) 1.57079) 50))
  81.              (command "offset" (/ (* lw bl) 2.0) (list entl p1) (list (car p3) (cadr p3)) "")
  82.              (setq entn (entlast))
  83.              (command "area" "e" entn)
  84.              (setq area1 (getvar "area"))
  85.              (command "offset" (/ (* lw bl) 2.0) (list entl p1) (list (car p4) (cadr p4)) "")
  86.              (setq entn0 (entlast))
  87.              (command "area" "e" entn0)
  88.              (setq area2 (getvar "area"))
  89.              (if (not (or (equal area1 0 0.1) (equal area2 0 0.1)))
  90.              (progn
  91.              (if (< area2 area1) (progn (entdel entn) (setq entn entn0)) (entdel entn0))
  92.              (command "pedit" entn "w" (* (- lw 0.1) bl) "")
  93.              (command "change" (entlast) "" "p" "la" "pwallw" "")
  94.              ))
  95. )
  96.  
  97. (defun atoplsub()
  98.              (setq enn (entget (setq snn (entnext entl))) p1 (cdr (assoc 10 enn)))
  99.              (redraw snn 3)
  100.              (setq p3 (getpoint p1 "\n╚╖╢¿╗í╧▀╡─╝╙┐φ╖╜╧≥:"))
  101.              (command "offset" (/ (* lw bl) 2.0) (list entl p1) (list (car p3) (cadr p3)) "")
  102.              (setq entn (entlast))
  103.              (command "erase" entl "")
  104.              (command "pedit" entn "w" (* (- lw 0.1) bl) "")
  105.              (command "change" (entlast) "" "p" "la" "pwallw" "")
  106. )
  107.