[LISP程序]：选择增强之：选择连续线功能!

fsxm · 发表于 2007-1-29 22:46:41

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

CAD的选择集是以对象本身特属性做选择的
但事实上我们有很多时候
是要用对象相对几何关系来选择一批对象
比如说在一堆乱七八糟的线中选择相互连续的一组线
这时就要用到选择连续线的功能了！
有很多CAD软件中就有这个功能如：ug,等等
但AUTOCAD却没有带让人很头晕

写了一个简单点的请大家试用：
等有时间再加上个选择连续且相切功能

(vl-load-com)
(defun gotonexten (en pt / box en2 en2lst ep i sp ss)
(setq box (* (/ (getvar "pickbox") (cadr (getvar "screensize")))
(getvar "viewsize")
)
)
(setq ss (ssget "c"
(mapcar '- pt (list box box))
(mapcar '+ pt (list box box))
)
)
(if ss
(progn
(ssdel en ss)
(setq i 0)
(while (setq en2 (ssname ss i))
(setq i (1+ i))
(setq
sp (vl-catch-all-apply 'vlax-curve-getStartPoint (list en2))
)
(if (listp sp)
(progn (setq ep (vlax-curve-getEndPoint en2))
(cond ((equal sp pt 1e-8)
(setq en2lst (cons (list en2 ep) en2lst))
)
((equal ep pt 1e-8)
(setq en2lst (cons (list en2 sp) en2lst))
)
)
)
)
)
)
)
en2lst
)
;;选择连续线c:ss -----fsxm 2007/01/29
(defun c:ss (/ en enp ept spt ss addnext)
(if (and (setq enp (entsel))
(ssget (cadr enp) '((0 . "*line,arc,circle,ellipse")))
)
(progn
(setq en (car enp))
(setq spt (vlax-curve-getStartPoint en))
(setq ept (vlax-curve-getendPoint en))
(setq ss (ssadd))
(ssadd en ss)
(defun addnext (en pt / next)
(if (setq next (gotonexten en pt))
(foreach a next
(if (not (ssmemb (car a) ss))
(progn (ssadd (car a) ss)
(apply 'addnext a)
)
)
)
)
)
(addnext en spt)
(addnext en ept)
(if (= 0 (getvar "cmdactive"))
(sssetfirst nil ss)
)
ss
)
(progn
(princ "\n未选取对象或选取了非curve类型对象!")
(princ)
)
)
)

(vl-load-com) 
(defun gotonexten (en pt / box en2 en2lst ep i sp ss) 
  (setq        box (* (/ (getvar "pickbox") (cadr (getvar "screensize"))) 
               (getvar "viewsize") 
            ) 
  ) 
  (setq        ss (ssget "c" 
                  (mapcar '- pt (list box box)) 
                  (mapcar '+ pt (list box box)) 
           ) 
  ) 
  (if ss 
    (progn 
      (ssdel en ss) 
      (setq i 0) 
      (while (setq en2 (ssname ss i)) 
        (setq i (1+ i)) 
        (setq 
          sp (vl-catch-all-apply 'vlax-curve-getStartPoint (list en2)) 
        ) 
        (if (listp sp) 
          (progn (setq ep (vlax-curve-getEndPoint en2)) 
                 (cond ((equal sp pt 1e-8) 
                        (setq en2lst (cons (list en2 ep) en2lst)) 
                       ) 
                       ((equal ep pt 1e-8) 
                        (setq en2lst (cons (list en2 sp) en2lst)) 
                       ) 
                 ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  en2lst 
) 
 
;;选择连续线c:ss -----fsxm 2007/01/29 
(defun c:ss (/ en enp ept spt ss addnext) 
  (if (and (setq enp (entsel)) 
           (ssget (cadr enp) '((0 . "*line,arc,circle,ellipse"))) 
      ) 
    (progn 
      (setq en (car enp)) 
      (setq spt (vlax-curve-getStartPoint en)) 
      (setq ept (vlax-curve-getendPoint en)) 
      (setq ss (ssadd)) 
      (ssadd en ss) 
      (defun addnext (en pt / next) 
        (if (setq next (gotonexten en pt)) 
          (foreach a next 
            (if        (not (ssmemb (car a) ss)) 
              (progn (ssadd (car a) ss) 
                     (apply 'addnext a) 
              ) 
            ) 
          ) 
        ) 
      ) 
      (addnext en spt) 
      (addnext en ept) 
      (if (= 0 (getvar "cmdactive")) 
        (sssetfirst nil ss) 
      ) 
      ss 
    ) 
    (progn 
      (princ "\n未选取对象或选取了非curve类型对象!") 
      (princ) 
    ) 
  ) 
)

jx2008 · 发表于 2007-1-30 23:28:46

好像不实用

雨箭风刀 · 发表于 2007-1-30 23:54:09

以前写的一个功能类似的程序
粘连选集,试试就知道(好像et也有类似的功能)
命令c:fss

aeo · 发表于 2007-2-2 22:12:07

我以前贴过

就是那个选其中一根线把线连成pl线的.

自己找一下

softbird · 发表于 2007-2-3 11:54:03

楼主，能否加入选择集功能，选择定长度（可以自己添加长度）的一些连续线，连接为矩形，这些线段是首尾相连的矩形线，原来是分散的line，现在要变为闭合的pline。主要应用于一些没有规律性的图框选择。

fsxm · 发表于 2007-2-3 21:32:59

选择连续&相切线:
主函c:ss数不变 gotonexten有点小改动另加个getangatpoint

(defun getangatpoint (en pt)
(rem (angle
'(0 0 0)
(vlax-curve-getFirstDeriv
en
(vlax-curve-getParamAtPoint en pt)
)
)
pi
)
)
(defun gotonexten (en pt / box en2 en2lst ep i sp ss *ang* enang)
(setq box (* (/ (getvar "pickbox") (cadr (getvar "screensize")))
(getvar "viewsize")
)
)
(setq ss (ssget "c"
(mapcar '- pt (list box box))
(mapcar '+ pt (list box box))
)
)
(setq enang (getangatpoint en pt))
(setq *ang* 1e-8)
(if ss
(progn
(ssdel en ss)
(setq i 0)
(while (setq en2 (ssname ss i))
(setq i (1+ i))
(setq
sp (vl-catch-all-apply 'vlax-curve-getStartPoint (list en2))
)
(if (listp sp)
(progn (setq ep (vlax-curve-getEndPoint en2))
(cond ((and (equal sp pt 1e-8)
(equal enang (getangatpoint en2 sp) *ang*)
)
(setq en2lst (cons (list en2 ep) en2lst))
)
((and (equal ep pt 1e-8)
(equal enang (getangatpoint en2 ep) *ang*)
)
(setq en2lst (cons (list en2 sp) en2lst))
)
)
)
)
)
)
)
en2lst
)

(defun getangatpoint (en pt) 
  (rem (angle 
         '(0 0 0) 
         (vlax-curve-getFirstDeriv 
           en 
           (vlax-curve-getParamAtPoint en pt) 
         ) 
       ) 
       pi 
  ) 
) 
(defun gotonexten (en pt / box en2 en2lst ep i sp ss *ang* enang) 
  (setq        box (* (/ (getvar "pickbox") (cadr (getvar "screensize"))) 
               (getvar "viewsize") 
            ) 
  ) 
  (setq        ss (ssget "c" 
                  (mapcar '- pt (list box box)) 
                  (mapcar '+ pt (list box box)) 
           ) 
  ) 
  (setq enang (getangatpoint en pt)) 
  (setq *ang* 1e-8) 
  (if ss 
    (progn 
      (ssdel en ss) 
      (setq i 0) 
      (while (setq en2 (ssname ss i)) 
        (setq i (1+ i)) 
        (setq 
          sp (vl-catch-all-apply 'vlax-curve-getStartPoint (list en2)) 
        ) 
        (if (listp sp) 
          (progn (setq ep (vlax-curve-getEndPoint en2)) 
                 (cond ((and (equal sp pt 1e-8) 
                             (equal enang (getangatpoint en2 sp) *ang*) 
                        ) 
                        (setq en2lst (cons (list en2 ep) en2lst)) 
                       ) 
                       ((and (equal ep pt 1e-8) 
                             (equal enang (getangatpoint en2 ep) *ang*) 
                        ) 
                        (setq en2lst (cons (list en2 sp) en2lst)) 
                       ) 
                 ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  en2lst 
)

另：softbird 你说的由于用的较少，有空与我私聊
小狂老大的附件没法下载！下了9次只见见次数在增加可就是下不来

twtwvl · 发表于 2008-5-31 00:41:12

这就是我一直想找的东东嘛

twtwvl · 发表于 2008-5-31 00:46:49

这个不错啊，更加科学，比粘连选择更进一了

yoyoho · 发表于 2008-10-12 21:01:41

雨箭风刀兄你好:
fss.rar 程序无法下载喔!
麻烦你查看一下!
谢谢你!

狂刀 · 发表于 2008-10-16 19:21:05

狂刀 · 发表于 2008-10-16 19:23:31

pj5110 · 发表于 2008-10-22 00:39:53

楼主不容易啊，辛苦了

jack2913 · 发表于 2008-10-23 17:33:01

这程序早有了

wowan1314 · 发表于 2013-4-11 11:26:22

有空学习下！对这个算法很感兴趣。

以前只知道
1、通过（ssget "c" pt pt）循环或递归得出。
2、通过（ssget "A" (点过滤)）循环或递归得出。

GTJ116600 · 发表于 2013-5-28 07:11:05

这个已经下载了，正在学习中

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

[LISP程序]：选择增强之：选择连续线功能!

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

本帖被以下淘专辑推荐:

相关帖子