[求助]：如何删除同心圆中的小圆

kevinchan · 发表于 2005-5-4 22:12:46

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

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

×

请问如何删除选择集中(setq test (ssget "x" '((0 . "CIRCLE"))))同心圆中的小圆?

st788796 · 发表于 2014-2-26 08:35:31

本帖最后由 st788796 于 2014-2-26 08:37 编辑

kwok 发表于 2014-2-26 07:46
找不到(fy:cset->objs)能提供一个吗？

应该是

(defun fy:cset->objs (/ lst)
(vlax-for obj (vla-get-activeselectionset (fy:cset))
(setq lst (cons obj lst))
)
lst
)
(defun fy:cset () (vla-get-activeselectionset (fy:acsets)))
(defun fy:acsets () (vla-get-selectionsets (fy:acdoc))

按照 ActiveX Modelspace 那个表很简单的
这个 fy app.vlx 函数中都是最基础的，没有什么高级地方

zxq0220 · 发表于 2005-5-4 23:34:04

(DEFUN C:DELSMC ()
(IF (SETQ SS (SSGET '((0 . "CIRCLE")))) (PROGN
(SETQ SL (SSLENGTH SS) I 0 SMC (SSADD))
(WHILE (< I SL)
(SETQ SN1 (SSNAME SS I) I (1+ I)
EN1 (ENTGET SN1)
PC1 (CDR (ASSOC 10 EN1))
R1 (CDR (ASSOC 40 EN1))
J I)
(WHILE (< J SL)
(SETQ SN2 (SSNAME SS J)
EN2 (ENTGET SN2)
PC2 (CDR (ASSOC 10 EN2))
R2 (CDR (ASSOC 40 EN2)))
(IF (EQUAL (DISTANCE PC1 PC2) 0.0 1E-3)
(IF (< R1 R2)
(SETQ SMC (SSADD SN1) SN1 SN2 EN1 EN2 PC1 PC2 R1 R2
SS (SSDEL SN1) SL (1- SL))
(SETQ SMC (SSADD SN2) SS (SSDEL SN2) SL (1- SL))
)
(SETQ J (1+ J))
)
)
)
(IF (> (SSLENGTH SMC) 0) (COMMAND "ERASE" SMC ""))
))
(PRINC)
)

kevinchan · 发表于 2005-5-5 00:41:59

最初由 zxq0220 发布
[B][code]
(DEFUN C:DELSMC ()
(IF (SETQ SS (SSGET '((0 . "CIRCLE")))) (PROGN
 (SETQ SL (SSLENGTH SS) I 0 SMC (SSADD))
 (WHILE (< I SL)
(SETQ SN1 (SSNAME SS I) I (1+ I)
 EN1 (ENTGET SN1... [/B]

(SSDEL SN1) 和(SSDEL SN2 )参数太少.
改成(SSDEL SN1 SS) 可以删除同心圆中的一个,不能同时删除所有同心圆中的小圆.

xyp1964 · 发表于 2005-5-5 11:33:59

程序完成显示有错误，未调试完：
[php]
(load "xyp_lib")
;|
如果已经下载xyp_lib并放到搜索路径下可以不再下载!
利用以下任何一种方式即可加载和运行通用函数内的所有子程序：
1.在每个程序内增加(load"xyp_lib")
2.在acad.lsp中增加(load"xyp_lib")
3.在command下输入(load"xyp_lib")
4.在菜单.mnl中增加(load"xyp_lib")
下载地址：http://www.xdcad.net/forum/showthread.php?s=&threadid=325268
|;
(defun c:test (/ ss pt ss1 s1 s2 i rad-max rad)
 (cmdla0)
 (setq ss (ssget "x" '((0 . "CIRCLE"))))
 (command ".undo" "BE")
 (while (setq s1 (ssname ss 0))
(setq pt (dxf 10 (entget s1))
 ss1 (ssget "x" (list (cons 0 "CIRCLE") (cons 10 pt)))
 ss (ssdiff ss ss1)
)
(if (<= (sslength ss) 1)
 (setq ss nil)
)
(if (> (sslength ss1) 1)
 (progn
(setq i -1
 rad-max (dxf 40 (entget (ssname ss1 0)))
)
(while (setq s2 (ssname ss1 (setq i (1+ i))))
 (setq rad (dxf 40 (entget s2)))
 (if (> rad-max rad)
 (entdel s2)
 (setq rad-max rad)
 )
)
 )
)
 )
 (command ".undo" "E")
 (cmdla1)
)
[/php]

zxq0220 · 发表于 2005-5-5 22:27:17

调试过的程序：

(DEFUN C:DELSMC ()
(IF (SETQ SS (SSGET '((0 . "CIRCLE")))) (PROGN
(SETQ SL (SSLENGTH SS) I 0 SMC (SSADD))
(WHILE (< I SL)
(SETQ SN1 (SSNAME SS I) I (1+ I)
EN1 (ENTGET SN1)
PC1 (CDR (ASSOC 10 EN1))
R1 (CDR (ASSOC 40 EN1))
J I)
(WHILE (< J SL)
(SETQ SN2 (SSNAME SS J)
EN2 (ENTGET SN2)
PC2 (CDR (ASSOC 10 EN2))
R2 (CDR (ASSOC 40 EN2)))
(IF (< (DISTANCE PC1 PC2) 1E-3) (PROGN
(SETQ SL (1- SL) J SL I 0)
(IF (< R1 R2)
(SETQ SMC (SSADD SN1 SMC) SS (SSDEL SN1 SS))
(SETQ SMC (SSADD SN2 SMC) SS (SSDEL SN2 SS))
)
)
(SETQ J (1+ J))
)
)
)
(IF (> (SSLENGTH SMC) 0) (COMMAND "ERASE" SMC ""))
))
(PRINC)
)

啵浪鼓 · 发表于 2005-5-5 22:40:50

啊，楼主的程序是删除同心圆的啊，我还以为只是删除同心且相等的圆呢，看错了~

kevinchan · 发表于 2005-5-6 01:37:44

最初由 zxq0220 发布
[B]调试过的程序：
[code]
(DEFUN C:DELSMC ()
(IF (SETQ SS (SSGET '((0 . "CIRCLE")))) (PROGN
 (SETQ SL (SSLENGTH SS) I 0 SMC (SSADD))
 (WHILE (< I SL)
(SETQ SN1 (SSNAME SS I) I (1+ I)
 ... [/B]

现在OK了.

ymcui2005 · 发表于 2014-2-24 10:49:57

zxq0220 发表于 2005-5-5 22:27
调试过的程序：

请问如何删除大圆

zxq0220 · 发表于 2014-2-24 20:54:26

ymcui2005 发表于 2014-2-24 10:49
请问如何删除大圆

将SN1和SN2互换。

st788796 · 发表于 2014-2-24 23:08:40

(defun c:tt (/ ss lst)
(if (setq ss (ssget '((0 . "circle"))))
(progn
(setq lst (mapcar '(lambda (x)
(list (xdrx_getpropertyvalue x "Center")
(list (xdrx_getpropertyvalue x "Radius")
x
)
)
)
(xdrx_pickset->ents ss)
)
lst (XD::List:GroupByIndex lst 1e-3)
lst (vl-sort (mapcar 'cdr lst)
'(lambda (e1 e2)
(> (car e1) (car e2)) ;_半径由大到小
)
)
)
(mapcar '(lambda (x)
(mapcar 'xdrx_entity_delete (cdr (mapcar 'cadr x)));_留最大圆
)
lst
)
)
)
(princ)
)

(defun c:tt (/ ss lst) 
  (if (setq ss (ssget '((0 . "circle")))) 
    (progn 
      (setq lst        (mapcar        '(lambda (x) 
                           (list (xdrx_getpropertyvalue x "Center") 
                                 (list (xdrx_getpropertyvalue x "Radius") 
                                       x 
                                 ) 
                           ) 
                         ) 
                        (xdrx_pickset->ents ss) 
                ) 
            lst        (XD::List:GroupByIndex lst 1e-3) 
            lst        (vl-sort (mapcar 'cdr lst) 
                         '(lambda (e1 e2) 
                            (> (car e1) (car e2)) ;_半径由大到小 
                          ) 
                ) 
      ) 
      (mapcar '(lambda (x) 
                 (mapcar 'xdrx_entity_delete (cdr (mapcar 'cadr x)));_留最大圆 
               ) 
              lst 
      ) 
    ) 
  ) 
  (princ) 
)

Free-Lancer · 发表于 2014-2-25 07:28:01

用几个函数替换就是 a/vlisp 版

(defun c:tt (/ lst)
(fy:begin)
(if (ssget '((0 . "circle")))
(progn
(setq lst (mapcar '(lambda (x)
(list (vlax-get x "Center")
(list (vlax-get x "Radius")
x
)
)
)
(fy:cset->objs)
)
lst (XD::List:GroupByIndex lst 1e-3)
lst (vl-sort (mapcar 'cdr lst)
'(lambda (e1 e2)
(> (car e1) (car e2)) ;_半径由大到小, 小于号就是留最小圆
)
)
)
(mapcar '(lambda (x)
(mapcar 'vla-delete (cdr (mapcar 'cadr x))) ;_留最大圆
)
lst
)
)
)
(fy:end)
(princ)
)

(defun c:tt (/ lst) 
  (fy:begin) 
  (if (ssget '((0 . "circle"))) 
    (progn 
      (setq lst        (mapcar        '(lambda (x) 
                           (list (vlax-get x "Center") 
                                 (list (vlax-get x "Radius") 
                                       x 
                                 ) 
                           ) 
                         ) 
                        (fy:cset->objs) 
                ) 
            lst        (XD::List:GroupByIndex lst 1e-3) 
            lst        (vl-sort (mapcar 'cdr lst) 
                         '(lambda (e1 e2) 
                            (> (car e1) (car e2)) ;_半径由大到小, 小于号就是留最小圆 
                          ) 
                ) 
      ) 
      (mapcar '(lambda (x) 
                 (mapcar 'vla-delete (cdr (mapcar 'cadr x))) ;_留最大圆 
               ) 
              lst 
      ) 
    ) 
  ) 
  (fy:end) 
  (princ) 
)

kwok · 发表于 2014-2-26 07:46:17

Free-Lancer 发表于 2014-2-25 07:28
用几个函数替换就是 a/vlisp 版

找不到(fy:cset->objs)能提供一个吗？

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

[求助] [求助]：如何删除同心圆中的小圆

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

相关帖子

评分

点评

点评

点评