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

saint720

Gu_xl 发表于 2010-10-14 12:04
问题解决了！

怎么不行啊

saint720

Gu_xl 发表于 2010-10-14 12:04
问题解决了！

程序里面 getline函数定义里面包含有getline函数

qcw911

来自： 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
)
;;;=================================================================*

springwillow

好程序，收藏了！

chwnin

好程序，正在找一个能选择首尾相连线段的。

chwnin

正在学，不知怎样实现 ？

200853006

顶啊! 好东西！

sz2014SZ

学习学习
                                          

bzhjl

好程序，学习了！

zzcollan

太野了，收藏