删除多段线或对象输出
Por favor，podemos ayudar a convertir este punto para poder seleccional varios contornos（polilínea）y mantener los segmentos que se interscan con una línea que cruza todos los contornos。
; Required Express tools
; OutSide Contour Delete with Extrim
; Found at http://forums.augi.com/showthread.php?t=55056
(defun C:OCD (/ en ss lst ssall bbox)
(vl-load-com)
(if (and (setq en (car(entsel "\nSelect contour (polyline): ")))
(wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE"))
(progn
(setq bbox (ACET-ENT-GEOMEXTENTS en))
(setq bbox (mapcar '(lambda(x)(trans x 0 1)) bbox))
(setq lst (ACET-GEOM-OBJECT-POINT-LIST en 1e-3))
(ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list en)))
(command "_.Zoom" "0.95x")
(if (null etrim)(load "extrim.lsp"))
(etrim en (polar
(car bbox)
(angle (car bbox)(cadr bbox))
(* (distance (car bbox)(cadr bbox)) 1.1)))
(if (and
(setq ss (ssget "_CP" lst))
(setq ssall (ssget "_X" (list (assoc 410 (entget en)))))
)
(progn
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(foreach e1 lst (ssdel e1 ssall))
(ACET-SS-ENTDEL ssall)
)
)
)
)
)
(princ "\nType OCD to start")
(princ)Por favor，modifique esta luz para selecciar el contorno múltiple y retener el segmento。
我把你的两条线合并在一起了。请不要创建多个线程来问同一个问题。
另外，这是一个英语论坛，所以请用英语发布你的问题。
非常感谢。 试试这个mod。。。最低限度测试。。。
; Required Express tools
; OutSide Contour Delete with Extrim
; Found at http://forums.augi.com/showthread.php?t=55056
; Modified for multiple contour processing by M.R.
(defun C:OCD ( / *error* LM:ConvexHull LM:Clockwise-p entnextparent adoc cmde sel i el en ss sss lst cp ssall bbox enx laylst elst fuzz )
(vl-load-com)
(defun *error* ( m )
(if cmde
(setvar 'cmdecho cmde)
)
(vla-endundomark adoc)
(if m
(prompt m)
)
(princ)
)
;; Convex Hull-Lee Mac
;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
(defun LM:ConvexHull ( lst / ch p0 )
(cond
( (< (length lst) 4) lst)
( (setq p0 (car lst))
(foreach p1 (cdr lst)
(if (or (< (cadr p1) (cadr p0))
(and (equal (cadr p1) (cadr p0) 1e-8) (< (car p1) (car p0)))
)
(setq p0 p1)
)
)
(setq lst (vl-remove p0 lst))
(setq lst (append (list p0) lst))
(setq lst
(vl-sort lst
(function
(lambda ( a b / c d )
(if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
(< (distance p0 a) (distance p0 b))
(< (if (equal c (* 2.0 pi) 1e-8) 0.0 c) (if (equal d (* 2.0 pi) 1e-8) 0.0 d))
)
)
)
)
)
(setq ch (list (cadr lst) (car lst)))
(foreach pt (cddr lst)
(setq ch (cons pt ch))
(while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
(setq ch (cons pt (cddr ch)))
)
)
(reverse ch)
)
)
)
;; Clockwise-p-Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
(defun LM:Clockwise-p ( p1 p2 p3 )
(<(-(* (- (carp2) (carp1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (carp3) (carp1)))
)
1e-8
)
)
(defun entnextparent ( e )
(while (and (setq e (entnext e)) (wcmatch (cdr (assoc 0 (entget e))) "ATTRIB,VERTEX,SEQEND")))
e
)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(if (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark adoc)
)
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(prompt "\nSelect contour polylines: ")
(while (not (setq sel (ssget "_:L" '((0 . "*POLYLINE") (-4 . "<or") (70 . 1) (70 . 129) (-4 . "or>")))))
(prompt "\nEmpty sel.set... Retry selecting again...")
)
(if (tblsearch "LAYER" "temp_layer")
(progn
(prompt "\nLayer \"temp_layer\" already present in active document... Please delete this layer as it is used by this routine and restart OCD again...")
(exit)
)
)
(if (null etrim) (load "extrim.lsp"))
(initget 6)
(setq fuzz (getdist "\nPick or specify fuzz distance for interpolation of reference polyline(s) <0.5> : "))
(if (null fuzz)
(setq fuzz 0.5)
)
(repeat (setq i (sslength sel))
(if laylst
(progn
(setq el (entlast))
(vl-cmdf "_.PASTECLIP" "_non" '(0.0 0.0 0.0))
(while (setq el (entnextparent el))
(setq elst (cons el elst))
)
)
)
(vla-startundomark adoc)
(setq en (ssname sel (setq i (1- i))))
(setq bbox (ACET-ENT-GEOMEXTENTS en))
(setq bbox (mapcar '(lambda ( x ) (trans x 0 1)) bbox))
(setq lst (ACET-GEOM-OBJECT-POINT-LIST en fuzz))
(setq cp (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car bbox) (cadr bbox)))
(setq lst (mapcar '(lambda ( x ) (mapcar '+ cp (mapcar '* (mapcar '- x cp) (list 1.05 1.05 1.05)))) lst))
(setq lst (LM:ConvexHull lst))
(vl-cmdf "_.ZOOM" "_OB" en "")
(vl-cmdf "_.ZOOM" "0.75x")
(etrim en (polar (car bbox) (angle (car bbox) (cadr bbox)) (* (distance (car bbox) (cadr bbox)) 1.1)))
(vl-cmdf "_.ZOOM" "_P")
(vl-cmdf "_.ZOOM" "_P")
(if (setq ss (ssget "_CP" lst))
(progn
(setq sss (ssadd))
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq enx (entget (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object e)))))
(setq laylst (cons (cdr (assoc 8 enx)) laylst))
(entupd (cdr (assoc -1 (entmod (subst (cons 8 "temp_layer") (assoc 8 enx) enx)))))
(ssadd (cdr (assoc -1 enx)) sss)
)
)
)
(vl-cmdf "_.COPYBASE" "_non" '(0.0 0.0 0.0) sss "")
(vl-cmdf "_.UNDO" "_B")
)
(setq el (entlast))
(vl-cmdf "_.PASTECLIP" "_non" '(0.0 0.0 0.0))
(while (setq el (entnextparent el))
(setq elst (cons el elst))
)
(setq ssall (ssget "_X" (list (cons 8 "~temp_layer"))))
(ACET-SS-ENTDEL ssall)
(mapcar '(lambda ( a b ) (entupd (cdr (assoc -1 (entmod (subst (cons 8 b) '(8 . "temp_layer") (entget a))))))) elst laylst)
(vl-cmdf "_.PURGE" "_LA" "temp_layer" "_N")
(*error* nil)
)HTH。，M、 R。 你听说过谷歌翻译吗？这毕竟是万维网。 谷歌翻译
页:
[1]