明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 15620|回复: 41

[基础] 首尾相连的N条直线 选中其中任何一条都能选中N条线段 如何用lisp实现啊

    [复制链接]
发表于 2010-10-13 15:42:00 | 显示全部楼层 |阅读模式

大家好

我有一个问题

就是

现在N条首尾相连的线段,需要选择任何一条线段,都可以吧整个N条线段全部选择

lisp如何编写?

拜托大家帮我编写一个lsp

本人初学lisp

"觉得好,就打赏"
还没有人打赏,支持一下
 楼主| 发表于 2013-3-19 15:10:58 | 显示全部楼层

来自: http://zml84.blog.sohu.com/221693089.html

;;;=================================================================*
;;;功能:连接首尾相连线条
;;;操作方式:点取一条,自动搜索相接对象,在分支处提示。
(defun c:xx (/ ss0 ss1 lst_en EN EN_BASE FIL I LET_EN LST LST_0        LST_1
             PT0 PT1 TMP)
  (princ "\n功能:连接首尾相连线条")

  ;;
  (or (setq *fuzz* (getdist "\n请输入连接精度<5>: "))
      (setq *fuzz* 5.0)
  )
  ;; 生成首尾相连选集.
  (if (and (setq fil '((0 . "LINE,ARC,*POLYLINE")))
           (setq ss0 (ssget "x" fil))
           (princ "\n请点取一条线:")
           (setq ss1 (ssget ":S" fil))
      )
    (progn

      ;;1、得到首个对象
      (setq en_base (ssname ss1 0)
            pt0            (vlax-curve-getStartPoint en_base)
            pt1            (vlax-curve-getEndPoint en_base)
      )
      ;;2、获取lst_en
      (setq let_en '()
            i           0
            ss0           (ssdel en_base ss0)
      )
      (repeat (sslength ss0)
        (setq en     (ssname ss0 i)
              lst_en (cons en lst_en)
              i             (1+ i)
        )
      )
      ;;3、计算起点处
      (setq lst_0 (xx-find lst_en pt0 *fuzz*))
      ;;4、计算终点处
      (foreach en lst_0
        (setq lst_en (vl-remove en lst_en))
      )
      (setq lst_1 (xx-find lst_en pt1 *fuzz*))
      (print lst_0)
      (print lst_1)
      (setq lst (append (reverse lst_0) (list en_base) lst_1))
      ;;4、连接操作
      (command "_.undo" "be")
      (setq tmp (getvar "PEDITACCEPT"))
      (setvar "PEDITACCEPT" 1)

      ;;方式一
      (command "_.pedit" "m" en_base)
      (foreach en (append lst_0 lst_1)
        (command en)
      )
      (command "" "j" *fuzz* "")

    )
  )
  (princ)
)
;;;=================================================================*
;;;查找符合要求的图元。                                             *
;;;要求:首尾相连,允许误差为fuzz。                                 *
;;;★★特别的:按照坐标差值判断,而不是两点间距计算。               *
(defun xx-find (lst_en pt fuzz / lst_jg en pt0 pt1 tmp pt_next)
  (setq lst_jg '())
  (foreach en lst_en
    (setq pt0 (vlax-curve-getStartPoint en)
          pt1 (vlax-curve-getEndPoint en)
    )
    (cond ((equal pt0 pt fuzz)
           (setq tmp        (list en pt0 pt1)
                 lst_jg        (cons tmp lst_jg)
           )
          )
          ((equal pt1 pt fuzz)
           (setq tmp        (list en pt1 pt0)
                 lst_jg        (cons tmp lst_jg)
           )
          )
    )
  )
  ;;判断并返回
  ;;若找到多个,则需要人工干预
  (cond        ((= lst_jg nil)
         nil
        )
        ((= (length lst_jg) 1)
         (setq tmp     (car lst_jg)
               en      (nth 0 tmp)
               pt_next (nth 2 tmp)
               lst_en  (vl-remove en lst_en)
         )
         (cons en (xx-find lst_en pt_next fuzz))
        )
        ((> (length lst_jg) 1)
         (setq tmp     (xx-sel-only lst_jg)
               en      (nth 0 tmp)
               pt_next (nth 2 tmp)
               lst_en  (vl-remove en lst_en)
         )
         (cons en (xx-find lst_en pt_next fuzz))
        )
  )
)
;;;=================================================================*
;;;提醒用户选择分支中的一个。
;;;参数:lst 格式:'((en  pt0  pt1)(en  pt0  pt1)..)
;;;返回:(en  pt0  pt1)
(defun xx-sel-only (lst / lst_en en pt0 pt1 tmp)
  ;;移动对象到屏幕中心位置
  (command "-pan" (trans (cadar lst) 0 1) (getvar "VIEWCTR"))
  
  ;;逐个对象高亮显示
  (and ZL-DRAW-GRVECS-CIRCLE
       (progn (ZL-DRAW-GRVECS-CIRCLE (trans (cadar lst) 0 1) 10 1)
              (ZL-DRAW-GRVECS-CIRCLE (trans (cadar lst) 0 1) 15 2)
       )
  )
  (setq lst_en (mapcar 'car lst))
  (mapcar '(lambda (en) (redraw en 3)) lst_en)

  ;;提示用户选择
  (while (not (and (setq tmp (car (entsel "\n点取分支:")))
                   (setq tmp (assoc tmp lst))
              )
         )
    ()
  )
  ;;逐个对象取消高亮显示
  (mapcar '(lambda (en) (redraw en 4)) lst_en)
  ;;返回
  tmp
)
;;;=================================================================*
回复 支持 2 反对 0

使用道具 举报

发表于 2010-10-13 23:17:00 | 显示全部楼层
还有几个问题要处理,比如相连的直线不在显示窗口内,无法选择出来,还有某一直线端点有多条直线的,要全部选择上,还有点麻烦,需要嵌套循环计算,越搞越复杂了,太晚了,睡觉先!等有空再搞吧!
回复 支持 1 反对 0

使用道具 举报

发表于 2017-11-23 21:29:54 | 显示全部楼层
;; ep-sjxz(神经选择)

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
回复 支持 1 反对 0

使用道具 举报

 楼主| 发表于 2010-10-13 20:10:00 | 显示全部楼层

没人顶啊? 帖子快沉下去了

发表于 2010-10-13 21:25:00 | 显示全部楼层
游客,本帖隐藏的内容需要发帖数高于 5 才可浏览,你当前发帖数只有 0

发表于 2010-10-13 23:08:00 | 显示全部楼层
赞一下ZZXXQQ版主,好思路!修正程序中几个小错误,并加以改进,直接选取直线,并亮显选择的直线:
  1. (defun c:tt ()
  2.   
  3.   (princ "\n选择直线:")
  4.   (setq enline (car (entsel)))
  5.   (setq ss (ssadd enline))
  6.   (setq pt (cdr (assoc 10 (entget enline))))
  7.   (setq pt1 (cdr (assoc 11 (entget enline))))
  8.   (if (setq en (ssget "C" pt pt1 '((0 . "LINE"))))
  9.     (progn
  10.       (setq n 0)
  11.       (while (and (< n (sslength en))(ssmemb (setq en1 (ssname en n)) ss)) (setq n (1+ n)))
  12.    (setq ent (entget en1)
  13.          p1 (cdr(assoc 10 ent))
  14.          p2 (cdr(assoc 11 ent)))
  15.    (if (equal (distance p2 pt) 0.0 0.001)
  16.     (setq p1 p2 p2 (cdr(assoc 10 ent)))
  17.    )
  18.    (setq ss (ssadd en1 ss))
  19.    (while (> (sslength(setq s1 (ssget "C" p2 p2 '((0 . "LINE"))))) 1)
  20.     (setq s1 (ssdel en1 s1))
  21. (setq en1 (ssname s1 0)
  22.           ent (entget en1)
  23.           p1 (cdr(assoc 10 ent)))
  24.     (if (equal (distance p1 p2) 0.0 0.001)
  25.      (setq p2 (cdr(assoc 11 ent)))
  26.      (setq p2 p1)
  27.     )
  28.     (setq ss (ssadd en1 ss))
  29.    )
  30.   ))
  31.   (if (setq en (ssget "C" pt pt1 '((0 . "LINE"))))
  32.     (progn
  33.       (setq n 0)
  34.       (while (and (< n (sslength en))(ssmemb (setq en1 (ssname en n)) ss)) (setq n (1+ n)))
  35.    (setq ent (entget en1)
  36.          p1 (cdr(assoc 10 ent))
  37.          p2 (cdr(assoc 11 ent)))
  38.    (if (equal (distance p2 pt) 0.0 0.001)
  39.     (setq p1 p2 p2 (cdr(assoc 10 ent)))
  40.    )
  41.    (setq ss (ssadd en1 ss))
  42.    (while (> (sslength(setq s1 (ssget "C" p2 p2 '((0 . "LINE"))))) 1)
  43.     (setq s1 (ssdel en1 s1))
  44. (setq en1 (ssname s1 0)
  45.           ent (entget en1)
  46.           p1 (cdr(assoc 10 ent)))
  47.     (if (equal (distance p1 p2) 0.0 0.001)
  48.      (setq p2 (cdr(assoc 11 ent)))
  49.      (setq p2 p1)
  50.     )
  51.     (setq ss (ssadd en1 ss))
  52.    )
  53.   ))
  54. (setq n 0)
  55.   (repeat (sslength ss)
  56.     (redraw (ssname ss n) 3)
  57.     (setq n (1+ n))
  58.     )
  59. ss
  60.   
  61. )

发表于 2010-10-14 06:44:00 | 显示全部楼层
本帖最后由 作者 于 2010-10-14 7:31:18 编辑

谢谢班主

谢谢Gu_xl

如果POLYLINE线也能选出或许更好,因为现在用POLYLINE作图的较多。

学习了

发表于 2010-10-14 12:04:00 | 显示全部楼层
本帖最后由 Gu_xl 于 2013-3-13 11:04 编辑
Gu_xl发表于2010-10-13 23:17:00还有几个问题要处理,比如相连的直线不在显示窗口内,无法选择出来,还有某一直线端点有多条直线的,要全部选择上,还有点麻烦,...

问题解决了!
  1. ;;选择直线相连 By Gu_xl
  2. (defun c:tt(/ gxl-Sel-ReDrawSel gxl-Sel-SSsub gxl-Sel-SSJoin gxl-sel-SSgetLineatPoint getline)
  3.   (defun gxl-Sel-ReDrawSel (Sel mode / m n)
  4.     (setq m (sslength Sel)
  5.    n 0)
  6.     (repeat m
  7. (redraw (ssname Sel n) mode)
  8. (setq n (1+ n))
  9. );repeat
  10.     )
  11.   (defun gxl-Sel-SSsub(ss1 ss2 / ss n)
  12. (cond
  13. ((and ss1 ss2)
  14.   (setq n 0)
  15.   (repeat (sslength ss2)
  16.     (ssdel (ssname ss2 n) ss1)
  17.     (setq n (1+ n))
  18.     )
  19. )
  20. ((and ss1 (not ss2))
  21.   ss1
  22. )
  23. (T
  24.   (setq ss1 nil)
  25. )
  26. )
  27. ss1
  28. )
  29.   (defun gxl-Sel-SSJoin ( ss1 ss2 / ename ss cnt )
  30. (if ss1
  31. (progn
  32. (if (= (type ss1) 'ENAME)
  33. (progn
  34.   (setq
  35.    ename ss1
  36.    ss1   (ssadd)
  37.   )
  38.   (ssadd ename ss1)
  39. ))
  40. ))
  41. (if ss2
  42. (progn
  43. (if (= (type ss2) 'ENAME)
  44. (progn
  45.   (setq
  46.    ename ss2
  47.    ss2   (ssadd)
  48.   )
  49.   (ssadd ename ss2)
  50. ))
  51. ))
  52. (setq ss (ssadd))
  53. (if (and ss1 ss2)
  54. (progn
  55. ;(setq ss ss2 cnt 0)
  56.         (setq  cnt 0)
  57.         (repeat (sslength ss2)
  58.   (ssadd (ssname ss2 cnt) ss)
  59.   (setq cnt (1+ cnt))
  60. )
  61.         (setq  cnt 0)
  62. (repeat (sslength ss1)
  63.   (ssadd (ssname ss1 cnt) ss)
  64.   (setq cnt (1+ cnt))
  65. )
  66. ))
  67. (if (and ss1 (not ss2))
  68. (setq ss ss1))
  69. (if (and ss2 (not ss1))
  70. (setq ss ss2))
  71. (if (> (sslength ss) 0)
  72.   ;;(eval ss)
  73. ss
  74. nil
  75. )
  76. )
  77.   (defun gxl-sel-SSgetLineatPoint (pt jd /  px py px0 px1 py0 py1 ss  pz)
  78. (setq px (car pt)
  79.       px0 (- px jd)
  80.       px1 (+ px jd)
  81.       py (cadr pt)
  82.       py0 (- py jd)
  83.       py1 (+ py jd)
  84.       pz (caddr pt)
  85.       )
  86.   (setq ss
  87. (ssget "x" (list '(0 . "line")
  88.    '(-4 . "<or")

  89.    '(-4 . "<and")
  90.    '(-4 . ">=,>=,=")
  91.    (list 10 px0 py0 pz)
  92.    '(-4 . "<=,<=,=")
  93.    (list 10 px1 py1 pz)
  94.    '(-4 . "and>")
  95.    
  96.    '(-4 . "<and")
  97.    '(-4 . ">=,>=,=")
  98.    (list 11 px0 py0 pz)
  99.    '(-4 . "<=,<=,=")
  100.    (list 11 px1 py1 pz)
  101.    '(-4 . "and>")
  102.    
  103.    '(-4 . "or>")
  104.    )
  105.        )
  106.   )
  107.   (if ss(GXL-SEL-REDRAWSEL ss 3))
  108.   ss
  109.   )
  110.   (defun getline (pt jd / s s1 n p1 p2)
  111.    
  112.     (setq s (gxl-sel-SSgetLineatPoint pt jd))
  113.     (if s
  114.       (progn
  115. (setq s1 (GXL-SEL-SSSUB s ssrtl)
  116.        ssrtl (GXL-SEL-SSJOIN ssrtl s1)
  117.        )

  118. (if s1
  119.    (progn
  120.      (setq n 0)
  121.      (repeat (sslength s1)
  122.        (setq p1 (cdr (assoc 10 (entget (ssname s1 n))))
  123.       p2 (cdr (assoc 11 (entget (ssname s1 n))))
  124.       )
  125.        (getline p2 jd)
  126.        (getline p1 jd)
  127.        (setq n (1+ n))
  128.        )
  129.      )
  130.    )
  131. )
  132.       )
  133.    
  134.     )
  135.   ;;;程序开始
  136.     (princ "\n选择直线:")
  137.   (setq enline (car (entsel)))
  138.   (initget 5 "  ")
  139.   (setq jd (getreal "输入容差精度:<0.001>"))
  140.   (if (= jd "")(setq jd 0.001))
  141.   (setq pt1 (cdr (assoc 10 (entget enline))))
  142.   (setq pt2 (cdr (assoc 11 (entget enline))))
  143. (setq ssrtl (ssadd enline))
  144.   (getline pt1 jd)
  145.   (getline pt2 jd)
  146.   ssrtl
  147.   )

评分

参与人数 1明经币 +1 金钱 +50 收起 理由
树櫴希德 + 1 + 50 很给力!最牛版主

查看全部评分

 楼主| 发表于 2010-10-14 20:57:00 | 显示全部楼层

谢谢 Gu_xl

谢谢 ZZXXQQ版主

能得到版主的回答很是荣幸

 楼主| 发表于 2010-10-14 21:00:00 | 显示全部楼层
这个飞诗编写的
我修改了一点点
结合成pl线了
  1. (vl-load-com)
  2. (defun gotonexten (en pt / box en2 en2lst ep i sp ss)
  3. (setq    box (* (/ (getvar "pickbox") (cadr (getvar "screensize")))
  4.      (getvar "viewsize")
  5.      )
  6. )
  7. (setq    ss (ssget "c"
  8.          (mapcar '- pt (list box box))
  9.          (mapcar '+ pt (list box box))
  10.      )
  11. )
  12. (if ss
  13. (progn
  14. (ssdel en ss)
  15. (setq i 0)
  16. (while (setq en2 (ssname ss i))
  17.     (setq i (1+ i))
  18.     (setq
  19.      sp (vl-catch-all-apply 'vlax-curve-getStartPoint (list en2))
  20.     )
  21.     (if (listp sp)
  22.      (progn (setq ep (vlax-curve-getEndPoint en2))
  23.          (cond ((equal sp pt 1e-8)
  24.             (setq en2lst (cons (list en2 ep) en2lst))
  25.          )
  26.          ((equal ep pt 1e-8)
  27.             (setq en2lst (cons (list en2 sp) en2lst))
  28.          )
  29.          )
  30.      )
  31.     )
  32. )
  33. )
  34. )
  35. en2lst
  36. )
  37. ;;选择连续线c:ss -----fsxm 2007/01/29
  38. (defun c:ss (/ en enp ept spt ss addnext)
  39. (if (and (setq enp (entsel))
  40.      (ssget (cadr enp) '((0 . "*line,arc,circle,ellipse")))
  41. )
  42. (progn
  43. (setq en (car enp))
  44. (setq spt (vlax-curve-getStartPoint en))
  45. (setq ept (vlax-curve-getendPoint en))
  46. (setq ss (ssadd))
  47. (ssadd en ss)
  48. (defun addnext (en pt / next)
  49.     (if (setq next (gotonexten en pt))
  50.      (foreach a next
  51.      (if    (not (ssmemb (car a) ss))
  52.      (progn (ssadd (car a) ss)
  53.          (apply 'addnext a)
  54.      )
  55.      )
  56.      )
  57.     )
  58. )
  59. (addnext en spt)
  60. (addnext en ept)
  61. (if (= 0 (getvar "cmdactive"))
  62.     (sssetfirst nil ss)
  63. )
  64. ss
  65. (jion)
  66. )
  67. (progn
  68. (princ "\n未选取对象或选取了非curve类型对象!")
  69. (princ)
  70. )
  71. )
  72. )
  73. (defun jion(/ ss s)
  74. (setq ss (ssget '((-4 . "<OR")
  75. (0 . "LINE")(0 . "ARC")
  76. (-4 . "<AND")(0 . "LWPOLYLINE")(70 . 0)(-4 . "AND>")
  77. (-4 . "OR>")))
  78. )
  79. (while ss
  80. (setq s (ssname ss 0))
  81. (if (or (= "LINE" (cdr (assoc 0 (entget s))))
  82. (= "ARC" (cdr (assoc 0 (entget s))))
  83. )
  84. (command "pedit" s "y" "j" "p" "" "x")
  85. (command "pedit" s "j" "p" "" "x")
  86. )
  87. (setq ss (ssget "p"))
  88. )
  89. (princ)
  90. )
发表于 2012-3-15 17:11:49 | 显示全部楼层
qcw911     修改的小程序是针对直线的连接,很好用。我现在更需要能连接pline 线的程序。
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-6 09:31 , Processed in 0.193126 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表