清除lisp例程增强
你好我正在使用附加的例程删除重复的实体。它运行良好且快速：30000个实体需要7分钟。但对于100000个实体来说，它只持续了70分钟：胡子：。
我可以节省45分钟使用交叉窗口输入实体在3个步骤。不幸的是，常规没有这种可能性。
有人可以修改它来添加交叉选择吗？
谢谢
清楚的lsp 尝试此优化：
(defun c:clear ( / a b ent enx lst )
(setq ent (entnext))
(while ent
(foreach dxf (entget ent)
(setq a (car dxf)
b (cdr dxf)
)
(cond
( (or (= 'ename (type b)) (= a 5)))
( (listp b)
(setq enx (cons (cons a (mapcar (function (lambda ( x ) (rtos x 2 )) b)) enx))
)
( (numberp b)
(setq enx (cons (cons a (rtos b 2 ) enx))
)
( (setq enx (cons dxf enx)))
)
)
(if (member enx lst)
(entdel ent)
(setq lst (cons enx lst))
)
(setq ent (entnext ent)
enx nil
)
)
(princ)
) 李，
谢谢你的代码。
我星期一试试。
祝你一切顺利。 李，
它可以工作：thumbsup：但我想有可能选择带有交叉窗口的实体。
你能帮我做这个吗？
谢谢
路易吉 试试这个修改Luigi，
(defun c:clear ( / a b ent enx i lst s )
(if (setq s (ssget "_:L"))
(repeat (setq i (sslength s))
(foreach dx (entget (setq ent (ssname s (setq i (1- i)))))
(setq a (car dx)
b (cdr dx)
)
(cond
( (or (= 'ename (type b)) (= a 5)))
( (listp b)
(setq enx (cons (cons a (mapcar (function (lambda ( x ) (rtos x 2 )) b)) enx))
)
( (numberp b)
(setq enx (cons (cons a (rtos b 2 ) enx))
)
( (setq enx (cons dx enx)))
)
)
(if (member enx lst)
(entdel ent)
(setq lst (cons enx lst))
)
(setq enx nil)
)
)
(princ)
) 李，
好的，它起作用了。
我画了一幅10万个小实体的画：汗水：。如果我试图同时清除它们，例程需要45分钟，如果我选择10000个带有交叉窗口的窗口，例程只需要30秒。
因此，如果我把工作分成十步，我需要30x10=300秒=5分钟，而不是45分钟，速度会增加很多：泵送：。有没有可能自动完成？我在考虑选择步骤的数量（如10），它会从上到下开始交叉选择循环。在循环的每个步骤中，只有选定的实体必须由例程清除。
我希望你明白我的要求。 李，
不在乎我昨天写的，这是我的错，因为我测试例程时使用了错误的测试文件。
我修改了您的代码，使用ssget“\u C”函数将作业分为多个步骤。
现在，对于大文件，该例程速度更快。
我还添加了一些代码以获得更好的输出。
任何其他提示都会得到。
非常感谢您的时间和好运。
路易吉
; clear.lsp: Delete duplicate entities, tested only on polylines and circles.
; Core routine by Lee Mac 04-08-2013
; Output results by Luigi Calderone 04-10-2013
;
(defun c:clear (/ old a b ent enx i lst s)
(setq xmin (car (getvar "EXTMIN"))
xmax (car (getvar "EXTMAX"))
ymin (car (cdr (getvar "EXTMIN")))
ymax (car (cdr (getvar "EXTMAX")))
old(ssget "_X")
N 10
J 0
)
(command "zoom" "e")
(prompt "\n")
(while (< J N)
(setq lst nil
s nil
pt1 (list xmin (+ ymin (/ (* (- ymax ymin) J) N)))
pt2 (list xmax (+ ymin (/ (* (- ymax ymin) (+ J 1)) N)))
J (+ J 1)
)
(if (setq s (ssget "_C" pt2 pt1))
(repeat (setq i (sslength s))
(foreach dx (entget (setq ent (ssname s (setq i (1- i)))))
(setq a (car dx)
b (cdr dx)
)
(cond
((or (= 'ename (type b)) (= a 5)))
((listp b)
(setq
enx (cons
(cons
a
(mapcar (function (lambda (x) (rtos x 2 )) b)
)
enx
)
)
)
((numberp b)
(setq enx (cons (cons a (rtos b 2 ) enx))
)
((setq enx (cons dx enx)))
)
)
(if (member enx lst)
(entdel ent)
(setq lst (cons enx lst))
)
(setq enx nil)
(cond (SPIN (setq SPIN NIL) (princ "\r\\"))
(t
(setq SPIN (princ "\r/")
SPIN (princ " ")
SPIN (princ (itoa J))
SPIN (princ "/")
SPIN (princ (itoa N))
)
)
)
)
)
)
(if (setq trap old)
(prompt (strcat "\nNumber of elements before clearing- "
(itoa (sslength old))
)
)
(prompt (strcat "\nNumber of elements before clearing- 0"))
)
(if (setq trap (ssget "_X"))
(prompt (strcat "\nNumber of elements after clearing- "
(itoa (sslength (ssget "_X")))
)
)
(prompt (strcat "\nNumber of elements after clearing- 0"))
)
(if (setq trap (ssget "_X"))
(prompt (strcat "\nNumber of elements cleared- "
(itoa (- (sslength old) (sslength (ssget "_X"))))
)
)
(prompt (strcat "\nNumber of elements cleared- 0"))
)
(princ)
);end file
(prompt "\nLoaded new command CLEAR. ")
(princ)
删除重复项的问题很有趣。
未测试具有属性的块。
下一个版本是否适用？
(defun C:CLEARs () ; 11 . 04 . 2013 .
(princ "\n Selects objects to Checked: ")
(if (setq sel (ssget) ) ;_ end of setq
(progn
(setq lsel (sslength sel)lseli lseli 0k 0) ;_ end of setq
(princ (strcat "\n Selected Items:" (itoa lsel) ";"))
(while (< i lsel)
(princ (strcat "\n Compare Object:" (itoa i) ";"))
(setq lobi (entget (ssname sel i))lobii (member (assoc 410 lobi) lobi)j (1+ i) ) ;_ end
(while (< j lsel)
(setq nmoj (ssname sel j)lobj (entget nmoj)lobjj (member (assoc 410 lobj) lobj) ) ;_ end
(if (equal lobii lobjj 0.000001)
(progn
(setq sel (ssdel nmoj sel)k (1+ k) ) ;_ end of setq
(princ (strcat "\n Delete Object Namber:" (itoa j) "from" (itoa lsel) "=" (itoa k) ";"))
(setq lsel (1- lsel) ) ;_ end of setq
(entdel nmoj)
) ;_ end of prog then
(setq j (1+ j)) ;_ end of setq
) ;_ end of if
) ;_ end of wh j
(setq i (1+ i)) ;_ end of setq
) ;_ end of wh i
)) ;_ end of if sel
(setq texte (strcat "\n\n Selected Items:" (itoa lseli) ";"
"\n Delete Objects:" (itoa k) ";" )) ;_ end of setq
(princ texte) (princ)
) ;_ end of defun
谢谢你的例行公事。
我检查了一下，但比两天前发布的要慢一点。
祝你一切顺利
路易吉 取消每个while循环中带有princ的所有帖子。
; (princ (strcat "\n Compare Object:" (itoa i) ";"))
. . .
; (princ (strcat "\n Delete Object:" (itoa j) "from" (itoa i) "=" (itoa k) ";"))
可以在进行测试的位置附着dwg？
页:
[1]
2