选择所有要删除的块
你好请有人张贴一个代码，将选择所有的块是接触多线。代码应该能够执行多个部分。
附着的模板DWG文件（我要选择选定管道尺寸上的所有喷水装置）
新建块。图纸 试试这个。。。适用于直线、圆弧、圆、多段线和样条曲线。。。
;;----------------=={ Entity to Point List }==----------------;;
;; ;;
;;Returns a list of points describing or approximating the;;
;;supplied entity, else nil if the entity is not supported. ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;ent - Entity for which to return Point List. ;;
;;------------------------------------------------------------;;
;;Returns:List of Points describing/approximating entity;;
;;------------------------------------------------------------;;
(defun LM:Entity->PointList ( ent / der di1 di2 di3 elst fun inc lst par rad )
(setq elst (entget ent))
(cond
( (eq "POINT" (cdr (assoc 0 elst)))
(list (cdr (assoc 10 elst)))
)
( (eq "LINE" (cdr (assoc 0 elst)))
(list (cdr (assoc 10 elst)) (cdr (assoc 11 elst)))
)
( (member (cdr (assoc 0 elst)) '("CIRCLE" "ARC"))
(setq di1 0.0
di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
inc (/ di2 (1+ (fix (* 35.0 (/ di2 (cdr (assoc 40 elst)) (+ pi pi))))))
fun (if (vlax-curve-isclosed ent) < <=)
)
(while (fun di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
di1 (+ di1 inc)
)
)
lst
)
( (or (eq (cdr (assoc 0 elst)) "LWPOLYLINE")
(and (eq (cdr (assoc 0 elst)) "POLYLINE") (zerop (logand (cdr (assoc 70 elst)) 80)))
)
(setq par 0)
(repeat (fix (1+ (vlax-curve-getendparam ent)))
(if (setq der (vlax-curve-getsecondderiv ent par))
(if (equal der '(0.0 0.0 0.0) 1e-
(setq lst (cons (vlax-curve-getpointatparam ent par) lst))
(if (setq rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent par))
di1 (vlax-curve-getdistatparam ent par)
di2 (vlax-curve-getdistatparam ent (1+ par))
)
(progn
(setq inc (/ (- di2 di1) (1+ (fix (* 35.0 (/ (- di2 di1) rad (+ pi pi)))))))
(while (< di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
di1 (+ di1 inc)
)
)
)
)
)
)
(setq par (1+ par))
)
(if (or (vlax-curve-isclosed ent) (equal '(0.0 0.0 0.0) der 1e-)
lst
(cons (vlax-curve-getendpoint ent) lst)
)
)
( (eq (cdr (assoc 0 elst)) "ELLIPSE")
(setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
di3 (* di2 (/ (+ pi pi) (abs (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)))))
)
(while (< di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
der (distance '(0.0 0.0) (vlax-curve-getsecondderiv ent (vlax-curve-getparamatdist ent di1)))
di1 (+ di1 (/ di3 (1+ (fix (/ 35.0 (/ di3 der (+ pi pi)))))))
)
)
(if (vlax-curve-isclosed ent)
lst
(cons (vlax-curve-getendpoint ent) lst)
)
)
( (eq (cdr (assoc 0 elst)) "SPLINE")
(setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
inc (/ di2 25.0)
)
(while (< di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
der (/ (distance '(0.0 0.0) (vlax-curve-getsecondderiv ent (vlax-curve-getparamatdist ent di1))) inc)
di1 (+ di1 (if (equal 0.0 der 1e-10) inc (min inc (/ 1.0 der (* 10. inc)))))
)
)
(if (vlax-curve-isclosed ent)
lst
(cons (vlax-curve-getendpoint ent) lst)
)
)
)
)
(defun remove:duplicate (l m / a n)
(while l
(setq a (car l))
(setq l (vl-remove-if
'(lambda (x)
(if (not m)
(eq x a)
(and (eq (car x) (car a))
(eq (cadr x) (cadr a))
(eq (caddr x) (caddr a))
))
)
l
)
)
(setq n (cons a n))
)
(reverse n)
)
(defun c:test (/ a b i i1 obj lst sel)
(if (setq a (ssget '((0 . "*line,arc,circle"))))
(progn
(setq sel (ssadd))
(repeat (setq i (sslength a))
(setq obj (ssname a (setq i (1- i))))
(setq lst (remove:duplicate (LM:Entity->PointList obj) t))
(if (setq b (ssget "_F" lst '((0 . "insert"))))
(repeat (setq i1 (sslength b))
(ssadd (ssname b (setq i1 (1- i1))) sel)
)
)
)
(sssetfirst nil sel)
)
)
(princ)
)
新1块。图纸 我已经按照您显示的例程创建了新代码。试一下
但是请记住（ssget“_X”'（（0。“insert”））在处理图形中显示的所有块时可能会花费太多时间。
(vl-load-com)
(defun c:slbl2 (/ _kpblc-conv-selset-to-ename pl selset res prec)
(defun _kpblc-conv-selset-to-ename (selset / tab item)
(cond
((not selset) nil)
((= (type selset) 'pickset)
(repeat (setq tabnil
item (sslength selset)
) ;_ end setq
(setq tab (cons (ssname selset (setq item (1- item))) tab))
) ;_ end repeat
)
) ;_ end of cond
) ;_ end of defun
(if (and (= (type (setq pl (vl-catch-all-apply
(function
(lambda ()
(car (entsel "\nSelect LWPolyline <Cancel> : "))
) ;_ end of lambda
) ;_ end of function
) ;_ end of vl-catch-all-apply
) ;_ end of setq
) ;_ end of type
'ename
) ;_ end of =
(setq selset (_kpblc-conv-selset-to-ename (ssget "_X" (list '(0 . "INSERT") (assoc 410 (entget pl))))))
) ;_ end of and
(progn
(setq prec 1e-1
pl (vlax-ename->vla-object pl)
selset (vl-remove-if-not
(function
(lambda (x / pt pt_closest)
(setq pt (cdr (assoc 10 (entget x)))
pt_closest (vlax-curve-getclosestpointto pl pt)
) ;_ end of setq
(< (distance pt pt_closest) prec)
) ;_ end of lambda
) ;_ end of function
selset
) ;_ end of vl-remove-if-not
res (ssadd)
) ;_ end of setq
(foreach item selset (ssadd item res))
(if (> (sslength res) 0)
(sssetfirst res res)
) ;_ end of if
) ;_ end of progn
) ;_ end of if
) ;_ end of defun 谢谢你，先生，
这一个有效 不客气
Satish，为什么删除我的代码头？ 对不起，先生。。。只是想减少我发布的代码长度。。。
我已经更新了 非常感谢。 您好，satishrajdev，您可以进一步修改代码，将块的图层更改为它们所在的多段线的图层吗。
谢谢 重复帖子
页:
[1]
2