检查线段是否断开。。。

egoroom

路过高手帮看看。。。发贴好多次了。。。无人解决。。。

荒野孤行

;;;*****查悬挂线 程序开始*****
(defun C:T1 (/ ptList ptNo)
  (princ "\n★功能：查找悬挂断开的线段集\n")
  (setvar "pickadd" 1)
  (setvar "osmode" 15359)
  (setvar "PICKDRAG" 0)
  (setvar "cmdecho" 0)
                                        ;  (wdy_timeset1)
  (command "undo" "be")
  (princ "\n请选取直线、多段线、样条曲线、圆弧：")
  (if (not (setq ss (ssget '((0 . "*LINE,ARC")))))
    (progn (princ "\未选中对象。程序退出！") (exit))
  )
  (initget 6)
  (if (not (setq jd (getreal "\n输入模糊距离：<0.001>"))) (setq jd 0.001))
  (initget 1)
  (setq ptBase (getpoint "\n指定标记引出线的位置点："))
  (command "LAYER" "M" "层标记-悬挂线" "C" "1" "层标记-悬挂线" "")
  (setvar "osmode" 0)
  (vl-load-com)
  (setq        i -1
        ptList nil
        ptNo nil
  )
  (repeat (sslength ss)
    (setq entnam  (ssname ss (setq i (1+ i)))
          obj          (vlax-ename->vla-object entnam)
          ptStart (vlax-curve-GetStartPoint obj)
          ptEnd          (vlax-curve-GetEndPoint obj)
    )
    (if        (not (vlax-curve-isclosed obj))
      (progn
        (setq ptList (cons ptStart ptList))
        (setq ptList (cons ptEnd ptList))
      )
    )
  )
  (prin1 ptList)
  (while (setq pt     (car ptList)
               ptList (cdr ptList)
         )
    (if        (wdy_cxgx_duibi pt ptList jd)
      (setq ptList (vl-remove pt ptList))
      (setq ptNo (cons pt ptNo))
    )
  )
  ;| (while (setq pt     (car ptList)
               ptList (cdr ptList)
         )
    (if        (member pt ptList)
      (setq ptList (vl-remove pt ptList))
      (setq ptNo (cons pt ptNo))
    )
  )|;                                        ;另一种写法，无精度判断，算法较差
  (if (not ptNo)
    (alert "提示：\n恭喜你！没有发现悬挂线对象。\n")
    (progn
      (foreach pt ptNo
        (command "LINE" pt ptBase "")
      )
      (alert
        "提示：\n发现了悬挂线对象！\n\n请根据“层标记-悬挂线”图层中的引出线位置点进行查看悬挂线位置点。\n"
      )
    )
  )
  (command "undo" "e")
  (setvar "osmode" 15359)
  (princ)
)

(defun wdy_cxgx_duibi (pt0 lst jd / TorF x)
  (setq TorF nil)
  (foreach x lst
    (if        (equal pt0 x jd)
      (setq TorF T)
    )
  )
  TorF
)
;;;*****查悬挂线 程序结束*****

egoroom

2. (defun c:ccc()
   
3.      (if (setq ssa (ssget '((0 . "LINE"))))
   
4.          (progn
   
5.              (setq ptb nil  i -1)
   
6.              (repeat (sslength ssa)
   
7.            (setq dxf (entget (ssname ssa (setq i (1+ i))))
   
8.           p10 (cdr (assoc 10 dxf))
   
9.           p11 (cdr (assoc 11 dxf))
   
10.    ptb (cons p11 (cons p10 ptb))
    
11.            )
    
12.       )
    
13.              (setq jgb nil fhz nil)
    
14.              (while (setq pt  (car ptb)
    
15.             ptb (cdr ptb)
    
16.       )
    
17.                  (if (member pt ptb)
    
18.        (setq ptb (vl-remove pt ptb)
    
19.       fhz (cons pt fhz)
    
20.        )
    
21.        (setq jgb (cons pt jgb))
    
22.    )
    
23.                
    
24.       )
    
25.       (mapcar '(lambda(x) (command "_circle" x 50)) jgb)
    
26.    
    
27.       ;变量tymlb储存刚好首尾相接直线的图元名列表
    
28.       (setq tymlb nil)
    
29.       (foreach pt fhz
    
30.                  (setq ssa (ssget "c" pt pt '((0 . "LINE")))
    
31.          i   -1
    
32.    )
    
33.           (repeat (sslength ssa)
    
34.        (if (not (member (setq ent (ssname ssa (setq i (1+ i)))) tymlb))
    
35.            (setq tymlb (cons ent tymlb))
    
36.        )
    
37.    )
    
38.       )
    
39.   )
    
40.      )
    
41.      (princ)
    
42. )

(defun c:ccc()<br />      (if (setq ssa (ssget '((0 . "LINE"))))<br />          (progn<br />              (setq ptb nil  i -1)<br />              (repeat (sslength ssa)<br />            (setq dxf (entget (ssname ssa (setq i (1+ i))))<br />           p10 (cdr (assoc 10 dxf))<br />           p11 (cdr (assoc 11 dxf))<br />    ptb (cons p11 (cons p10 ptb))<br />            )<br />       )<br />              (setq jgb nil fhz nil)<br />              (while (setq pt  (car ptb)<br />             ptb (cdr ptb)<br />       )<br />                  (if (member pt ptb)<br />        (setq ptb (vl-remove pt ptb)<br />       fhz (cons pt fhz)<br />        )<br />        (setq jgb (cons pt jgb))<br />    )<br />                 <br />       )<br />       (mapcar '(lambda(x) (command "_circle" x 50)) jgb)<br />     <br />       ;变量tymlb储存刚好首尾相接直线的图元名列表<br />       (setq tymlb nil)<br />       (foreach pt fhz<br />                  (setq ssa (ssget "c" pt pt '((0 . "LINE")))<br />          i   -1<br />    )<br />           (repeat (sslength ssa)<br />        (if (not (member (setq ent (ssname ssa (setq i (1+ i)))) tymlb))<br />            (setq tymlb (cons ent tymlb))<br />        )<br />    )<br />       )<br />   )<br />      )<br />      (princ)<br /> )

egoroom

上面是论坛源吗。。只支持直线。。。
高手们帮改个对直线，圆弧，圆，多段线，样条曲线，二维三维多段线都支持的。。。

egoroom

2. (defun c:ccc()
   
3.      (if (setq ssa (ssget '((0 . "LINE"))))
   
4.          (progn
   
5.              (setq ptb nil  i -1)
   
6.              (repeat (sslength ssa)
   
7.            (setq dxf (entget (ssname ssa (setq i (1+ i))))
   
8.           p10 (cdr (assoc 10 dxf))
   
9.           p11 (cdr (assoc 11 dxf))
   
10.    ptb (cons p11 (cons p10 ptb))
    
11.            )
    
12.       )
    
13.              (setq jgb nil fhz nil)
    
14.              (while (setq pt  (car ptb)
    
15.             ptb (cdr ptb)
    
16.       )
    
17.                  (if (member pt ptb)
    
18.        (setq ptb (vl-remove pt ptb)
    
19.       fhz (cons pt fhz)
    
20.        )
    
21.        (setq jgb (cons pt jgb))
    
22.    )
    
23.                
    
24.       )
    
25.       (mapcar '(lambda(x) (command "_circle" x 50)) jgb)
    
26.    
    
27.       ;变量tymlb储存刚好首尾相接直线的图元名列表
    
28.       (setq tymlb nil)
    
29.       (foreach pt fhz
    
30.                  (setq ssa (ssget "c" pt pt '((0 . "LINE")))
    
31.          i   -1
    
32.    )
    
33.           (repeat (sslength ssa)
    
34.        (if (not (member (setq ent (ssname ssa (setq i (1+ i)))) tymlb))
    
35.            (setq tymlb (cons ent tymlb))
    
36.        )
    
37.    )
    
38.       )
    
39.   )
    
40.      )
    
41.      (princ)
    
42. )

(defun c:ccc()<br />      (if (setq ssa (ssget '((0 . "LINE"))))<br />          (progn<br />              (setq ptb nil  i -1)<br />              (repeat (sslength ssa)<br />            (setq dxf (entget (ssname ssa (setq i (1+ i))))<br />           p10 (cdr (assoc 10 dxf))<br />           p11 (cdr (assoc 11 dxf))<br />    ptb (cons p11 (cons p10 ptb))<br />            )<br />       )<br />              (setq jgb nil fhz nil)<br />              (while (setq pt  (car ptb)<br />             ptb (cdr ptb)<br />       )<br />                  (if (member pt ptb)<br />        (setq ptb (vl-remove pt ptb)<br />       fhz (cons pt fhz)<br />        )<br />        (setq jgb (cons pt jgb))<br />    )<br />                 <br />       )<br />       (mapcar '(lambda(x) (command "_circle" x 50)) jgb)<br />     <br />       ;变量tymlb储存刚好首尾相接直线的图元名列表<br />       (setq tymlb nil)<br />       (foreach pt fhz<br />                  (setq ssa (ssget "c" pt pt '((0 . "LINE")))<br />          i   -1<br />    )<br />           (repeat (sslength ssa)<br />        (if (not (member (setq ent (ssname ssa (setq i (1+ i)))) tymlb))<br />            (setq tymlb (cons ent tymlb))<br />        )<br />    )<br />       )<br />   )<br />      )<br />      (princ)<br /> )

egoroom

这是论坛另一源码。。。都只支持直线

egoroom

http://bbs.mjtd.com/thread-90624-1-1.html
原文连接。。。

egoroom

在线等。。。难道只有悬赏贴有人回复。。。解决吗。。。

自贡黄明儒

楼主要求不明，难怪无人回答。是不是想检查线、弧是否围成了封闭图形？
(> (sslength (ssget "c" pt pt '((0 . "*LINE,ARC"))) 1)
;;pt为端点

freehand8008

去下载个燕秀，有这功能

egoroom

自贡黄明儒 发表于 2012-7-19 11:21
楼主要求不明，难怪无人回答。是不是想检查线、弧是否围成了封闭图形？
(> (sslength (ssget "c" pt pt '( ...

你仔细看要求了吗。。