home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1993 #2 / Image.iso / cad / may93.zip / TIP870.LSP < prev    next >
Text File  |  1993-05-12  |  4KB  |  138 lines
  1. ; TIP870.LSP   [DELOUT.LSP]
  2. ;   Delete Outside of Windoe   (c)1993, Wolf Praetorius
  3.  
  4. (defun C:DELOUT ( / cmde pt1 pt2 A1 A2 pt3 pt4 ss1 ss2 ss3)
  5.    (setq m:err *error* *error* *merr*
  6.       cmde (getvar "CMDECHO")
  7.    )
  8.    (setvar "CMDECHO" 0)
  9.    (setq pt1 (getpoint "\nFirst corner of area to be retained : ")
  10.       pt2 (getcorner pt1 "\nOther corner: ")
  11.    )
  12.    (command "_.PLINE" pt1 (list (car pt1) (cadr pt2))
  13.       pt2 (list (car pt2) (cadr pt1))
  14.       "_C"
  15.    )
  16.    (setq A1 (angle pt2 pt1))
  17.    (setq A2 (angle pt1 pt2))
  18.    (setq pt3 (polar pt1 A1 0.1))
  19.    (setq pt4 (polar pt2 A2 0.1))
  20.    (command "trim" pt1 "" "FENCE" pt3 (list (car pt3) (cadr pt4)) ""
  21.       "FENCE" (list (car pt3) (cadr pt4)) pt4 ""
  22.       "FENCE" pt4 (list (car pt4) (cadr pt3)) ""
  23.    "FENCE" (list (car pt4) (cadr pt3)) pt3 "" "")
  24.  
  25.    (setq picked nil)
  26.    (setq cntr1 0)
  27.    (setq cntr2 0)
  28.    (setq cntr3 0)
  29.    (setq cntr4 0)
  30.    (setq cntr6 0)
  31.    (setq ss3 (ssadd))
  32.  
  33.    ;------Define selection set #1 (entity(s) to-be-retained)------------
  34.  
  35.    (while (not picked)
  36.       (prompt "\nWindow entity(s) to-be-retained:")(prin1)
  37.  
  38.       (setq ss1 (ssget "w" pt1 pt2))
  39.       (if (/= ss1 nil)
  40.          (progn
  41.             (prompt "\nWorking...")(prin1)
  42.             (setq ss1lng (sslength ss1))
  43.             (setq picked 0)
  44.          )
  45.          (progn
  46.             (prompt "\nERROR: No Entity(s) Found - Select Again...")
  47.             (prin1)
  48.          )
  49.       )
  50.    )
  51.  
  52.    ;------Find all layers in current drawing-----------------------------
  53.  
  54.    (setq lyr (tblnext "layer" T))
  55.  
  56.    (while (/= cntr3 nil)
  57.       (if (and (or (= (cdr (assoc 70 lyr)) 64)
  58.                (= (cdr (assoc 70 lyr)) 0)
  59.             )
  60.             (/= (minusp (cdr (assoc 62 lyr))) T)
  61.          )
  62.          (progn
  63.             (setq incrval (itoa cntr4))
  64.             (setq cntr4 (1+ cntr4))
  65.             (set (read (strcat "lyr" incrval))
  66.             (cons 8 (cdr (assoc 2 lyr))))
  67.             (setq lyr (tblnext "layer"))
  68.          )
  69.          (setq lyr (tblnext "layer"))
  70.       )
  71.  
  72.       (cond
  73.          ((= lyr nil)
  74.             (setq cntr3 nil)
  75.          )
  76.  
  77.       )
  78.    )
  79.  
  80.    ;------Build selection set #2 & #3 (of displayed entitys)-------------
  81.  
  82.    (setq cntr5 (1- cntr4))
  83.    (setq cntr4 0)
  84.  
  85.    (while (<= cntr4 cntr5)
  86.       (setq incrval (itoa cntr4))
  87.       (setq ss2 (ssget "x" (list (eval (read (strcat "lyr" incrval))))))
  88.  
  89.       (if (/= ss2 nil)
  90.          (progn
  91.             (while (< cntr6 (sslength ss2))
  92.                (setq enty (ssname ss2 cntr6))
  93.                (setq ss3 (ssadd enty ss3))
  94.                (setq cntr6 (1+ cntr6))
  95.             )
  96.          )
  97.       ) 
  98.  
  99.       (setq cntr4 (1+ cntr4))
  100.       (setq cntr6 0)
  101.    )
  102.  
  103.    ;------Determine if entity(s) exist in both selection sets (#2 & #3)--
  104.  
  105.    (setq ss2 (ssadd))
  106.  
  107.    (while (< cntr2 (sslength ss3))
  108.       (setq entnm3 (ssname ss3 cntr2))
  109.       (if (not (ssmemb entnm3 ss1))
  110.          (progn
  111.             (setq ss2 (ssadd entnm3 ss2))
  112.             (setq cntr2 (1+ cntr2))
  113.          )
  114.          (setq cntr2 (1+ cntr2))
  115.       )
  116.    )
  117.  
  118.    ;------Delete all entity(s) outside of defined window-----------------
  119.  
  120.    (if (/= (sslength ss2) 0)
  121.       (progn
  122.          (command ".erase" ss2 "")
  123.          (prompt "\n\n")
  124.          (princ (sslength ss2))(princ " entity(s) found & DELETED...")
  125.          (prin1)
  126.       )
  127.       (progn
  128.          (prompt "\nNO entity(s) found outside defined window...")(prin1)
  129.       )
  130.    )
  131.  
  132.    (setvar "CMDECHO" cmde)
  133.    (setq *error* m:err m:err nil)
  134.    (princ)
  135.    (command "redraw")
  136. ) ; END
  137. 
  138.