CAD中快速查找图元

刘炎华

求助：怎么在选中一条线或多义线后，全图范围内查找相同的对象。感谢！

taoyi0727

(defun c:tt (/ judge l lst-name name obj ss t-get-length t-length)
        (defun T-get-Length (obj / t-length)
                (cond
                        ((or
                                 (= (vla-get-ObjectName obj) "AcDbPolyline")
                                 (= (vla-get-ObjectName obj) "AcDbLine")
                         )
                                (setq T-Length (vla-get-Length obj))
                        )
                        ((= (vla-get-ObjectName obj) "AcDbArc")
                                (setq T-Length (vla-get-ArcLength obj))
                        )
                        ((= (vla-get-ObjectName obj) "AcDbCircle")
                                (setq T-Length (* pi (vla-get-Radius obj) 2))
                        )
                        ((= (vla-get-ObjectName obj) "AcDbSpline")
                                (setq endpar (vlax-curve-getEndParam obj))
                                (setq T-Length (vlax-curve-getDistAtParam obj endpar))
                        )
                )
                T-Length
        )
        (setq judge t)
        (while (and
                                         judge
                                         (setq ss (ssget ":E:S"))
                                 )
                (setq obj (vlax-ename->vla-object (ssname ss 0)))
                (setq T-Length (T-get-Length obj))
                (if T-Length
                        (progn
                                (setq ss (ssget "x"))
                                (while (setq name (ssname ss 0))
                                        (setq l (T-get-Length (vlax-ename->vla-object name)))
                                        (if (equal T-Length l 0.1);容差0.1,这个自己根据需要来改
                                                (setq lst-name (append lst-name (list name)))
                                        )
                                        (ssdel name ss)
                                )
                                (setq judge nil)
                        )
                )
        )
        (if lst-name
                (progn
                        (setq ss (ssadd))
                        (foreach x lst-name
                                (ssadd x ss)
                        )
                        (sssetfirst nil ss)
                        (princ (strcat "\n找到 " (itoa (sslength ss)) " 个对象\n"))
                        (princ)
                )
        )
)
看下是不是这样的

linheyuanpcb

http://bbs.mjtd.com/forum.php?mo ... hlight=%D7%E9%BA%CF
搜索一下

qiannianhuazi

查找相同多义线.命令 FJ 试试查找多义线(可以有效避免选取镜像的,对称的多义线,且可提示位置和数量)

bai2000

楼上能加个个数统计会更好

taoyi0727

bai2000 发表于 2019-12-25 17:01
楼上能加个个数统计会更好

已经加上数量统计了

linheyuanpcb

taoyi0727 发表于 2019-12-25 14:56
(defun c:tt (/ judge l lst-name name obj ss t-get-length t-length)
        (defun T-get-Length (obj / t-le ...

加上个只选择物体所在图层的？

xyp1964

1. (defun c:tt () ;同长、同图层曲线
   
2.   (if (setq s1 (car (entsel "\n选曲线: ")))
   
3.     (progn
   
4.       (setq ll (xyp-CurveLength s1)
   
5.             la (xyp-DXF 8 s1)
   
6.             i  -1
   
7.             qf (list '(0 . "*LINE,ARC,CIRCLE,ELLIPSE") (cons 8 la))
   
8.             ss (ssget "x" qf)
   
9.             ss1 (ssadd)
   
10.       )
    
11.       (while (setq s1 (ssname ss (setq i (1+ i))))
    
12.         (if (equal (xyp-CurveLength s1) ll 1e-3)(ssadd s1 ss1))
    
13.       )
    
14.       (sssetfirst nil ss1)
    
15.       (princ (strcat "\n找到 " (itoa (sslength ss1)) " 个对象"))
    
16.     )
    
17.   )
    
18.   (princ)
    
19. )

(defun c:tt () ;同长、同图层曲线<br />   (if (setq s1 (car (entsel "\n选曲线: ")))<br />     (progn<br />       (setq ll (xyp-CurveLength s1)<br />             la (xyp-DXF 8 s1)<br />             i  -1<br />             qf (list '(0 . "*LINE,ARC,CIRCLE,ELLIPSE") (cons 8 la))<br />             ss (ssget "x" qf)<br />             ss1 (ssadd)<br />       )<br />       (while (setq s1 (ssname ss (setq i (1+ i))))<br />         (if (equal (xyp-CurveLength s1) ll 1e-3)(ssadd s1 ss1))<br />       )<br />       (sssetfirst nil ss1)<br />       (princ (strcat "\n找到 " (itoa (sslength ss1)) " 个对象"))<br />     )<br />   )<br />   (princ)<br /> )

刘炎华

taoyi0727 发表于 2019-12-25 14:56
(defun c:tt (/ judge l lst-name name obj ss t-get-length t-length)
        (defun T-get-Length (obj / t-le ...

非常感谢!帮我解决了这个问题

刘炎华

taoyi0727 发表于 2019-12-25 13:39
(defun c:tt (/ judge l lst-name name obj ss t-get-length t-length)
        (defun T-get-Length (obj / t-le ...

您好！如果图档太大查找会卡死，可以设条件查找对象为相同图层吗？