批量删除小于一定长度的多段线和直线问题瓶颈

newbuser

在此我写了个删除图形内小于一定长度的小程序，可不知哪里出的问题，我的界定方式明明是小于等于，而等于却不发挥作用。且LINE和LWPOLYLINE删除的情况也有差异，第一次运行删除成功，若将夹点移动拉长多段线（直线），再UNDO回来，程序却无法删除满足条件的线了。还请版主赐教啊。

1. (defun c:minl(/ ltdl ss lst)
   
2.   (setq dim (getvar 'dimzin))
   
3.   (setvar 'dimzin 0)
   
4.   (princ "\n 删除小于、等于一定长度的直线或者多段线")
   
5.   (initget 4)
   
6.   (setq ltdl (getreal "\n 请输入可容许的最小线段长度==>> "))
   
7.   (setq ss (ssget '((0 . "LWPOLYLINE,LINE"))))
   
8.   (setq lst (ss->lst ss))
   
9.   (setq lst (mapcar 'vlax-ename->vla-object lst))
   
10.   (deleteminlength lst ltdl)
    
11.   )
    
12. ;;删除小于容许vla实体值函数
    
13. (defun deleteminlength ( lst ltdl / )
    
14.   (vl-remove-if 'not (mapcar
    
15.            '(lambda (x)
    
16.         (if (<= (vla-get-length x) ltdl)
    
17. ;;;          x
    
18.           (vla-delete x)
    
19.         )
    
20.       )
    
21.            lst
    
22.          )
    
23.   )
    
24.   (setvar 'dimzin dim)
    
25. )
    
26. 
    
27. 
    
28. (defun ss->lst (SS / I EN LST_EN)
    
29.     (setq LST_EN '()
    
30.     I 0
    
31.     )
    
32.     (repeat (sslength SS)
    
33.   (setq EN     (ssname SS I)
    
34.         LST_EN (cons EN LST_EN)
    
35.         I       (1+ I)
    
36.   )
    
37.     )
    
38.     ;;返回
    
39.     (reverse LST_EN)
    
40. )

(defun c:minl(/ ltdl ss lst)<br />   (setq dim (getvar 'dimzin))<br />   (setvar 'dimzin 0)<br />   (princ "\n 删除小于、等于一定长度的直线或者多段线")<br />   (initget 4)<br />   (setq ltdl (getreal "\n 请输入可容许的最小线段长度==>> "))<br />   (setq ss (ssget '((0 . "LWPOLYLINE,LINE"))))<br />   (setq lst (ss->lst ss))<br />   (setq lst (mapcar 'vlax-ename->vla-object lst))<br />   (deleteminlength lst ltdl)<br />   )<br /> ;;删除小于容许vla实体值函数<br /> (defun deleteminlength ( lst ltdl / )<br />   (vl-remove-if 'not (mapcar<br />            '(lambda (x)<br />         (if (<= (vla-get-length x) ltdl)<br /> ;;;          x<br />           (vla-delete x)<br />         )<br />       )<br />            lst<br />          )<br />   )<br />   (setvar 'dimzin dim)<br /> )<br /> <br /> <br /> (defun ss->lst (SS / I EN LST_EN)<br />     (setq LST_EN '()<br />     I 0<br />     )<br />     (repeat (sslength SS)<br />   (setq EN     (ssname SS I)<br />         LST_EN (cons EN LST_EN)<br />         I       (1+ I)<br />   )<br />     )<br />     ;;返回<br />     (reverse LST_EN)<br /> )

gzxl

我怎么测试了下，是正常的

yoyoho

autocad 2011 测试---程序正常!

琴剑江山_10184

我也试了下，没什么问题啊，正常使用

yoyoho

500w008 发表于 2020-7-6 21:29
(defun c:xx ();repeat函数
(setq bs (ssget '((0 . "line")(8 . "beam"))))
(setq si -1)

(defun c:xx ();repeat函数
(setq bs (ssget '((0 . "line"))))
(setq si -1)
(setq ss_n (sslength bs))
(repeat ss_n
  (progn
     (setq s_ent (ssname bs (setq si (1+ si))))
     (setq ss_att (entget s_ent))
     (setq ss_s (cdr (assoc 10 ss_att)) ss_e (cdr (assoc 11 ss_att)))
     (setq dd (distance ss_s ss_e))
     (IF (< dd 1000) (command "erase" s_ent ""))
  )
);repeat
(princ)
)