xskfq 发表于 2014-2-3 19:41:49

求合并，2次框选变1次框选

(defun c:nydd( / center circle i index l lineobj point point_01 point_02 radius sscircle ssline syh x)
(vl-load-com)
(SETQ SS1 NIL)
(if (setq ssLine (ssget '((0 . "LINE")))) (progn
(setq i -1 ss1 (ssadd))
(repeat (sslength ssLine)
   (setq ent (entget (setq en (ssname ssLine (setq i (1+ i))))))
   (if (< (distance (cdr(assoc 10 ent)) (cdr(assoc 11 ent))) 5000)
    (ssadd en ss1)
   )
)
)
)
(command "erase" ss1 "")
;)
(setvar "cmdecho" 0)
(princ "\n请选取要处理的直线对象")
(if(setq ssLine (ssget '((0 . "LINE"))))
(progn
(setq syh 0)
      (vl-cmdf ".zoom" "e")
      (repeat (sslength ssLine)
(entmod(setq LineObj(ssname ssLine syh)syh(1+ syh)
       point(entget LineObj)
       LineObj(vlax-ename->vla-object LineObj)
       Point_01(cdr(assoc 10 point))
       Point_01(list(car Point_01)(cadr Point_01)0)
       Point_02(cdr(assoc 11 point))
       Point_02(list(car Point_02)(cadr Point_02)0)
       point(subst(cons 10 Point_01)(assoc 10 point)point)
       point(subst(cons 11 Point_02)(assoc 11 point)point)))
(if(setq ssCircle(ssget"F"(list Point_01 Point_02)'((0 . "CIRCLE"))))
   (progn (setq index 0)
   (repeat (sslength ssCircle)
       (entmod(setq Circle (entget(ssname ssCircle index))index(1+ index)
      radius(cdr(assoc 40 Circle))
      Center(vlax-curve-getClosestPointTo LineObj (cdr(assoc 10 Circle)) t)
      center(if(<(distance Point_01 Center)radius)Point_01
       (if(<(distance Point_02 Center)radius)Point_02 Center))
      circle(subst(cons 10 Center)(assoc 10 Circle)Circle)))
      )
      (setq l nil)
      (repeat (setq i (sslength ssCircle))
            (setq l (cons (cdr (assoc 10 (entget (ssname ssCircle (setq i (1- i)))))) l))
      )
      (mapcar '(lambda(x) (vl-cmdf "break" (list (ssname (ssget "c" x x '((0 . "*line"))) 0) x) x)) l)
      )))
    (vl-cmdf ".zoom" "p")
    (alert "完成！")
    ))
(princ)
)


--------------------------------------
先祝大家新年愉快！

第一次框选命令效果是删除短线，第二次框选命令效果是调整圆心位置等，如何只框选一次实现，求高手指点，谢谢！！

q3_2006 发表于 2014-2-3 19:41:50

本帖最后由 q3_2006 于 2014-2-4 13:24 编辑

(defun c:cx ( / center circle en ent i index l lineobj point point_01 point_02 radius ss1 sscircle ssline syh x)
(setq ss1 nil
ssline (ssget '((0 . "line")))
i -1
ss1 (ssadd)
)
(repeat (sslength ssline)
   (setq ent (entget (setq en (ssname ssline (setq i (1+ i))))))
   (if (< (distance (cdr(assoc 10 ent)) (cdr(assoc 11 ent))) 50)
    (ssadd en ss1)
   )
)
(command "select" ssline "r" ss1 "")
(setq ssline (ssget "p"))
(command "erase" ss1 "")
(progn (setq syh 0)
      (vl-cmdf ".zoom" "e")
      (repeat (sslength ssLine)
(entmod(setq LineObj(ssname ssLine syh)syh(1+ syh)
       point(entget LineObj)
       LineObj(vlax-ename->vla-object LineObj)
       Point_01(cdr(assoc 10 point))
       Point_01(list(car Point_01)(cadr Point_01)0)
       Point_02(cdr(assoc 11 point))
       Point_02(list(car Point_02)(cadr Point_02)0)
       point(subst(cons 10 Point_01)(assoc 10 point)point)
       point(subst(cons 11 Point_02)(assoc 11 point)point)))
(if(setq ssCircle(ssget"F"(list Point_01 Point_02)'((0 . "CIRCLE"))))
   (progn (setq index 0)
   (repeat (sslength ssCircle)
       (entmod(setq Circle (entget(ssname ssCircle index))index(1+ index)
      radius(cdr(assoc 40 Circle))
      Center(vlax-curve-getClosestPointTo LineObj (cdr(assoc 10 Circle)) t)
      center(if(<(distance Point_01 Center)radius)Point_01
       (if(<(distance Point_02 Center)radius)Point_02 Center))
      circle(subst(cons 10 Center)(assoc 10 Circle)Circle)))
      )
      (setq l nil)
      (repeat (setq i (sslength ssCircle))
            (setq l (cons (cdr (assoc 10 (entget (ssname ssCircle (setq i (1- i)))))) l))
      )
      (mapcar '(lambda(x) (vl-cmdf "break" (list (ssname (ssget "c" x x '((0 . "*line"))) 0) x) x)) l)
      )))
    (vl-cmdf ".zoom" "p")
    (alert "完成！")
    )
)

xskfq 发表于 2014-2-3 22:08:07

我有一个思路：根据第一次框选择，得到最大包围框（盒）boundingBox，做为第二次框选范围，不可以吗？不知道具体怎么写、、

lsjj 发表于 2014-2-3 23:19:49

1. 選線後,依條件分二條路走就可以了
也可以
2. 程序中未被刪除的線形成一個選集
也可以
3. 變成二個副程序,在一個程序中分別調用

xyp1964 发表于 2014-2-4 01:22:11



xskfq 发表于 2014-2-4 12:02:55

q3_2006 发表于 2014-2-4 06:21 static/image/common/back.gif
(defun c:nydd( / center circle i index l lineobj point point_01 point_02 radius sscircle ssline syh...

好像不行，错误提示“命令: NYDD
选择对象: 指定对角点: 找到 5 个
选择对象:
; 错误: 参数太多”
我开始也这个写的， 错在哪呢？？

xskfq 发表于 2014-2-4 13:10:34

广义来说就是：如何在主程序执行前 过滤删除超短线

xskfq 发表于 2014-2-4 13:24:02

我帖一下俩个源程序

-------------------------------

(defun c:cx ()
(SETQ SS1 NIL)
(if (setq ss (ssget '((0 . "LINE")))) (progn
(setq i -1 ss1 (ssadd))
(repeat (sslength ss)
   (setq ent (entget (setq en (ssname ss (setq i (1+ i))))))
   (if (< (distance (cdr(assoc 10 ent)) (cdr(assoc 11 ent))) 50)
    (ssadd en ss1)
   )
)
))
(command "erase" ss1 "")
)


----------------------------------------------------------------------------------------------





(defun c:nydd( / center circle i index l lineobj point point_01 point_02 radius sscircle ssline syh x)
(vl-load-com)
(setvar "cmdecho" 0)
(princ "\n请选取要处理的直线对象")
(if(setq ssLine (ssget '((0 . "LINE"))))
    (progn (setq syh 0)
      (vl-cmdf ".zoom" "e")
      (repeat (sslength ssLine)
(entmod(setq LineObj(ssname ssLine syh)syh(1+ syh)
       point(entget LineObj)
       LineObj(vlax-ename->vla-object LineObj)
       Point_01(cdr(assoc 10 point))
       Point_01(list(car Point_01)(cadr Point_01)0)
       Point_02(cdr(assoc 11 point))
       Point_02(list(car Point_02)(cadr Point_02)0)
       point(subst(cons 10 Point_01)(assoc 10 point)point)
       point(subst(cons 11 Point_02)(assoc 11 point)point)))
(if(setq ssCircle(ssget"F"(list Point_01 Point_02)'((0 . "CIRCLE"))))
   (progn (setq index 0)
   (repeat (sslength ssCircle)
       (entmod(setq Circle (entget(ssname ssCircle index))index(1+ index)
      radius(cdr(assoc 40 Circle))
      Center(vlax-curve-getClosestPointTo LineObj (cdr(assoc 10 Circle)) t)
      center(if(<(distance Point_01 Center)radius)Point_01
       (if(<(distance Point_02 Center)radius)Point_02 Center))
      circle(subst(cons 10 Center)(assoc 10 Circle)Circle)))
      )
      (setq l nil)
      (repeat (setq i (sslength ssCircle))
            (setq l (cons (cdr (assoc 10 (entget (ssname ssCircle (setq i (1- i)))))) l))
      )
      (mapcar '(lambda(x) (vl-cmdf "break" (list (ssname (ssget "c" x x '((0 . "*line"))) 0) x) x)) l)
      )))
    (vl-cmdf ".zoom" "p")
    (alert "完成！")
    ))
(princ)
)

q3_2006 发表于 2014-2-4 13:28:22

(defun c:cx ( / center circle en ent i index l lineobj point point_01 point_02 radius ss1 sscircle ssline syh x)
(if (setq ssline (ssget '((0 . "line"))))
(progn
(setq ss1 nil
i -1
ss1 (ssadd)
)
(repeat (sslength ssline)
   (setq ent (entget (setq en (ssname ssline (setq i (1+ i))))))
   (if (< (distance (cdr(assoc 10 ent)) (cdr(assoc 11 ent))) 50)
    (ssadd en ss1)
   )
)
(command "select" ssline "r" ss1 "")
(setq ssline (ssget "p"))
(command "erase" ss1 "")
(progn (setq syh 0)
      (vl-cmdf ".zoom" "e")
      (repeat (sslength ssLine)
(entmod(setq LineObj(ssname ssLine syh)syh(1+ syh)
       point(entget LineObj)
       LineObj(vlax-ename->vla-object LineObj)
       Point_01(cdr(assoc 10 point))
       Point_01(list(car Point_01)(cadr Point_01)0)
       Point_02(cdr(assoc 11 point))
       Point_02(list(car Point_02)(cadr Point_02)0)
       point(subst(cons 10 Point_01)(assoc 10 point)point)
       point(subst(cons 11 Point_02)(assoc 11 point)point)))
(if(setq ssCircle(ssget"F"(list Point_01 Point_02)'((0 . "CIRCLE"))))
   (progn (setq index 0)
   (repeat (sslength ssCircle)
       (entmod(setq Circle (entget(ssname ssCircle index))index(1+ index)
      radius(cdr(assoc 40 Circle))
      Center(vlax-curve-getClosestPointTo LineObj (cdr(assoc 10 Circle)) t)
      center(if(<(distance Point_01 Center)radius)Point_01
       (if(<(distance Point_02 Center)radius)Point_02 Center))
      circle(subst(cons 10 Center)(assoc 10 Circle)Circle)))
      )
      (setq l nil)
      (repeat (setq i (sslength ssCircle))
            (setq l (cons (cdr (assoc 10 (entget (ssname ssCircle (setq i (1- i)))))) l))
      )
      (mapcar '(lambda(x) (vl-cmdf "break" (list (ssname (ssget "c" x x '((0 . "*line"))) 0) x) x)) l)
      )))
    (vl-cmdf ".zoom" "p")
    (alert "完成！")
    )
)
)
)

434939575 发表于 2014-2-28 20:16:08

xyp1964 发表于 2014-2-4 01:22 static/image/common/back.gif


这个有意思！一箭双雕！
页: [1]
查看完整版本: 求合并，2次框选变1次框选