检查线段是否断开。。。

egoroom · 发表于 2012-7-19 10:42:32

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

荒野孤行 · 发表于 2017-8-23 22:59:56

;;;*****查悬挂线程序开始*****
(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 · 发表于 2012-7-19 10:45:50

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

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

egoroom · 发表于 2012-7-19 10:47:24

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

egoroom · 发表于 2012-7-19 10:53:58

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

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

egoroom · 发表于 2012-7-19 10:54:32

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

egoroom · 发表于 2012-7-19 10:55:59

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

egoroom · 发表于 2012-7-19 10:56:58

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

自贡黄明儒 · 发表于 2012-7-19 11:21:27

本帖最后由自贡黄明儒于 2012-7-19 11:27 编辑

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

freehand8008 · 发表于 2012-7-19 12:45:55

去下载个燕秀，有这功能

egoroom · 发表于 2012-7-28 14:04:20

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

你仔细看要求了吗。。

账号		自动登录	找回密码
密码			注册

检查线段是否断开。。。

本帖子中包含更多资源

点评

相关帖子