重叠块删除程序优化

andyzha · 发表于 2020-5-30 09:40:21

本帖最后由 andyzha 于 2020-6-3 09:13 编辑

在论坛里找到了一个删除叠加在一起重复块的lisp，检测很完善，但是移除重复块的时候会报错，cad版本是2020，求助大神修复完善一下。源码是yjr111大神作品，只是搬运，期待完善。

;;;OO，删除重复块，注意:镜像块或不同比例相同块有中心重合同样会被认为重叠;;;;;;;;;
;;;为防止误删，建议先移动出去查看后再确认删除;;;;;;;;;;;;;;;;;;;;
(defun c:oo (/ mydoc fuzz ss n ess css e1 s1 pt lst_p lst_e
t0 ksl key lstt l ep_lst move2p
movep ep_lst1 ep_lst2)
(defun *error* (msg)
(if (wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*")
(princ "\n程序已经被取消!")
(princ (strcat "\n" msg))
)
(if (and css (> (sslength css)) 0)
(command "_.erase" css "")
)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(princ)
)
(setq mydoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-StartUndoMark mydoc)
(setvar "CMDECHO" 0)
(setq oldosmode (getvar 'osmode)
oldorthomode(getvar 'orthomode)
)
(setvar 'osmode 0)
(setvar 'orthomode 0)
(setvar 'cecolor "1")
(prompt "\n选择需要检查的范围：")
(setq fuzz (getreal "\n请输入重叠间距,注意图纸比例!<30.0>"))
(if (not fuzz)
(setq fuzz 30.0);;;重叠点可调间距，请自行决定
)
(if (setq ss (ssget '((0 . "INSERT"))))
(progn
(setq n 0
ess (ssadd)
css (ssadd)
)
(setq t0 (vtime));;;;计时开始
(while (< n (sslength ss))
(setq e1 (ssname ss n)
s1 (entget e1)
p10 (cdr (assoc 10 s1))
)
(setq pt (getbound e1));;;最好不要用插入点
(if (null pt)
(princ"\n无法获取该块包围框!")
)
(if (= n 0)
(progn
(if pt
(setq lst_p (cons pt lst_p))
(setq lst_p (cons p10 lst_p))
)
(setq lst_e (cons e1 lst_e))
)
(progn
(vl-member-if
(function
(lambda (x)
(if
(and
(equal pt x fuzz)
(=
(cdr (assoc 2 s1))
(cdr (assoc
2
(entget (nth (vl-position x lst_p) lst_e))
)
)
)
)
(setq lstt (cons t lstt))
)
)
)
lst_p
);;;关键
(if (member t lstt)
(progn
(setq ess (ssadd e1 ess))
(if (and pt (> l 0));;;点块为L=0
(progn
(setq ep_lst(append ep_lst (list(list pt e1))))
(command "_.circle" pt (* 0.55 l));;;画标记圆
)
(progn
(cond((> l 0)
(setq ep_lst(append ep_lst (list(list p10 e1))))
(command "_.circle" p10 (* 0.55 l));;;画标记圆
)
((= l 0)
(alert"\n你好运气，发现点块!")
(setq ep_lst(append ep_lst (list(list p10 e1))))
(command "_.circle" p10 10));;;画标记圆
)
)
)
(setq css (ssadd (entlast) css))
(setq lstt nil
l nil
)
)
(progn
(if pt
(setq lst_p (cons pt lst_p))
(setq lst_p (cons p10 lst_p))
)
(setq lst_e (cons e1 lst_e))
)
)
)
)
(grtext -2
(strcat "程序正在运行...查找已经完成"
(rtos (* (/ n (float (sslength ss))) 100) 2 2)
"%"
)
)
(setq n (1+ n))
)
(princ (strcat "\n查找操作共耗时"
(rtos (- (vtime) t0) 2 2)
"秒。*****"
)
)
(if (and ess (> (setq ksl (sslength ess)) 0))
(progn
(princ (strcat "\n真遗憾，找到" (itoa ksl) "个重叠块!"))
(sssetfirst ess ess)
(sssetfirst css css)
(initget 128 "Move Delete")
(setq key (getkword
"\n请选择:[直接删除(Delete)/移动出去查看(Move)]"
)
)
(if (not key)
(setq key "Delete")
)
(command "_.erase" css "")
(if (= key "Move")
(progn
(setq move2p(getpoint"\n移动至..."))
(cond
((or(< (cadr move2p)(car(vl-sort (mapcar 'cadar ep_lst)'<)))
(> (cadr move2p)(car(vl-sort (mapcar 'cadar ep_lst)'>)))
)
(setq ep_lst2(vl-sort ep_lst (function(lambda(x y)(< (caar x)(caar y))))))
);;;最上或最下
((or(< (car move2p)(car(vl-sort (mapcar 'caar ep_lst)'<)))
(> (car move2p)(car(vl-sort (mapcar 'caar ep_lst)'>)))
);;;最左或最右
(setq ep_lst1(vl-sort ep_lst (function(lambda(x y)(< (cadar x)(cadar y))))))
)
)
(setq n 0)
(repeat (sslength ess)
(command "move" (if ep_lst1 (cadr(nth n ep_lst1))(cadr(nth n ep_lst2))) ""
(if ep_lst1(car(nth n ep_lst1))(car(nth n ep_lst2)))
(if ep_lst2
(setq movep(list (+(car move2p)(* n 1500)) (cadr move2p)))
(setq movep(list (car move2p) (+(cadr move2p)(* n 1500))))
)
)
(command "line" (if ep_lst1(car(nth n ep_lst1))(car(nth n ep_lst2))) movep "")
(setq n (1+ n))
)
)
(progn
(command "_.erase" ess "");;;直接删除
(princ (strcat "\n共删除" (itoa ksl) "个重叠块"))
)
)
)
(princ (strcat "\n恭喜你，未找到重叠块!"))
)
)
)
(setvar 'osmode oldosmode)
(setvar 'orthomode oldorthomode)
(vla-EndUndoMark mydoc)
(setvar "CMDECHO" 1)
(princ)
)
;;;1、计算耗时
(defun vtime ()
(* 86400 (getvar "tdusrtimer"))
)
;;;2、求得所选物体的外包框对角线中点
(defun getbound (e / p1 p2)
(setq vla_e (vlax-ename->vla-object e))
(if (not (vl-catch-all-error-p
(vl-catch-all-apply
'vla-getboundingbox
(list vla_e 'p1 'p2)
)
)
)
(progn
(setq p1 (vlax-safearray->list p1)
p2 (vlax-safearray->list p2)
)
(setq l (distance p1 p2))
(setq p3 (polar p1 (angle p1 p2) (/ l 2)))
)
)
)
(princ "\n删除重叠块 by yjr111 2012-4-4 命令:deldumpk")

;;;OO，删除重复块，注意:镜像块或不同比例相同块有中心重合同样会被认为重叠;;;;;;;;; 
;;;为防止误删，建议先移动出去查看后再确认删除;;;;;;;;;;;;;;;;;;;; 
(defun c:oo (/ mydoc fuzz ss n ess css e1 s1 pt lst_p lst_e 
         t0 ksl key lstt l ep_lst move2p 
         movep ep_lst1 ep_lst2) 
  (defun *error* (msg) 
    (if  (wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*") 
      (princ "\n程序已经被取消!") 
      (princ (strcat "\n" msg)) 
    ) 
    (if  (and css (> (sslength css)) 0) 
      (command "_.erase" css "") 
    ) 
    (vla-EndUndoMark 
      (vla-get-ActiveDocument (vlax-get-acad-object)) 
    ) 
    (princ) 
  ) 
  (setq mydoc (vla-get-ActiveDocument (vlax-get-acad-object))) 
  (vla-StartUndoMark mydoc) 
  (setvar "CMDECHO" 0) 
  (setq oldosmode (getvar 'osmode) 
  oldorthomode(getvar 'orthomode) 
  ) 
  (setvar 'osmode 0) 
  (setvar 'orthomode 0) 
  (setvar 'cecolor "1") 
  (prompt "\n选择需要检查的范围：") 
  (setq fuzz (getreal "\n请输入重叠间距,注意图纸比例!<30.0>")) 
  (if (not fuzz) 
    (setq fuzz 30.0);;;重叠点可调间距，请自行决定 
  ) 
  (if (setq ss (ssget '((0 . "INSERT")))) 
    (progn 
      (setq n  0 
      ess  (ssadd) 
      css  (ssadd) 
      ) 
      (setq t0 (vtime));;;;计时开始 
      (while (< n (sslength ss)) 
  (setq e1  (ssname ss n) 
        s1  (entget e1) 
        p10 (cdr (assoc 10 s1)) 
  ) 
  (setq pt (getbound e1));;;最好不要用插入点 
  (if (null pt) 
    (princ"\n无法获取该块包围框!") 
    ) 
  (if (= n 0) 
    (progn 
      (if  pt 
        (setq lst_p (cons pt lst_p)) 
        (setq lst_p (cons p10 lst_p)) 
      ) 
      (setq lst_e (cons e1 lst_e)) 
    ) 
    (progn 
      (vl-member-if 
        (function 
    (lambda  (x) 
      (if 
        (and 
          (equal pt x fuzz) 
          (= 
      (cdr (assoc 2 s1)) 
      (cdr (assoc 
             2 
             (entget (nth (vl-position x lst_p) lst_e)) 
           ) 
      ) 
          ) 
        ) 
         (setq lstt (cons t lstt)) 
      ) 
    ) 
        ) 
        lst_p 
      );;;关键 
      (if  (member t lstt) 
        (progn 
    (setq ess (ssadd e1 ess)) 
    (if (and pt (> l 0));;;点块为L=0 
      (progn 
      (setq ep_lst(append ep_lst (list(list pt  e1)))) 
      (command "_.circle" pt (* 0.55 l));;;画标记圆 
      ) 
      (progn 
      (cond((> l 0) 
            (setq ep_lst(append ep_lst (list(list p10  e1)))) 
            (command "_.circle" p10 (* 0.55 l));;;画标记圆 
           ) 
           ((= l 0) 
      (alert"\n你好运气，发现点块!") 
      (setq ep_lst(append ep_lst (list(list p10  e1)))) 
            (command "_.circle" p10 10));;;画标记圆 
           ) 
      ) 
    ) 
    (setq css (ssadd (entlast) css)) 
    (setq lstt nil 
          l     nil 
    ) 
        ) 
        (progn 
    (if pt 
      (setq lst_p (cons pt lst_p)) 
      (setq lst_p (cons p10 lst_p)) 
    ) 
    (setq lst_e (cons e1 lst_e)) 
        ) 
      ) 
    ) 
  ) 
  (grtext  -2 
    (strcat  "程序正在运行...查找已经完成" 
      (rtos (* (/ n (float (sslength ss))) 100) 2 2) 
      "%" 
    ) 
  ) 
  (setq n (1+ n)) 
      ) 
      (princ (strcat "\n查找操作共耗时" 
         (rtos (- (vtime) t0) 2 2) 
         "秒。*****" 
       ) 
      ) 
      (if (and ess (> (setq ksl (sslength ess)) 0)) 
  (progn 
    (princ (strcat "\n真遗憾，找到" (itoa ksl) "个重叠块!")) 
    (sssetfirst ess ess) 
    (sssetfirst css css) 
    (initget 128 "Move Delete") 
    (setq  key (getkword 
          "\n请选择:[直接删除(Delete)/移动出去查看(Move)]" 
        ) 
    ) 
    (if (not key) 
      (setq key "Delete") 
    ) 
    (command "_.erase" css "") 
    (if (= key "Move") 
      (progn 
        (setq move2p(getpoint"\n移动至...")) 
         (cond 
       ((or(< (cadr move2p)(car(vl-sort (mapcar 'cadar ep_lst)'<))) 
           (> (cadr move2p)(car(vl-sort (mapcar 'cadar ep_lst)'>))) 
           ) 
              (setq ep_lst2(vl-sort ep_lst (function(lambda(x y)(< (caar x)(caar y)))))) 
        );;;最上或最下 
       ((or(< (car move2p)(car(vl-sort (mapcar 'caar ep_lst)'<))) 
            (> (car move2p)(car(vl-sort (mapcar 'caar ep_lst)'>))) 
           );;;最左或最右 
              (setq ep_lst1(vl-sort ep_lst (function(lambda(x y)(< (cadar x)(cadar y)))))) 
        ) 
         ) 
        (setq n 0) 
        (repeat (sslength ess) 
     (command "move" (if ep_lst1 (cadr(nth n  ep_lst1))(cadr(nth n  ep_lst2))) "" 
        (if ep_lst1(car(nth n  ep_lst1))(car(nth n  ep_lst2))) 
          (if ep_lst2 
       (setq movep(list (+(car move2p)(* n 1500)) (cadr move2p))) 
       (setq movep(list (car move2p) (+(cadr move2p)(* n 1500)))) 
        ) 
      ) 
    (command "line" (if ep_lst1(car(nth n  ep_lst1))(car(nth n  ep_lst2))) movep "") 
    (setq n (1+ n)) 
         ) 
       ) 
      (progn 
      (command "_.erase" ess "");;;直接删除 
      (princ (strcat "\n共删除" (itoa ksl) "个重叠块")) 
      ) 
    ) 
  ) 
  (princ (strcat "\n恭喜你，未找到重叠块!")) 
      ) 
    ) 
  ) 
  (setvar 'osmode oldosmode) 
  (setvar 'orthomode oldorthomode) 
  (vla-EndUndoMark mydoc) 
  (setvar "CMDECHO" 1) 
  (princ) 
) 
;;;1、计算耗时 
(defun vtime () 
  (* 86400 (getvar "tdusrtimer")) 
) 
;;;2、求得所选物体的外包框对角线中点 
(defun getbound  (e / p1 p2) 
  (setq vla_e (vlax-ename->vla-object e)) 
  (if (not (vl-catch-all-error-p 
       (vl-catch-all-apply 
         'vla-getboundingbox 
         (list vla_e 'p1 'p2) 
       ) 
     ) 
      ) 
    (progn 
      (setq p1 (vlax-safearray->list p1) 
      p2 (vlax-safearray->list p2) 
      ) 
      (setq l (distance p1 p2)) 
      (setq p3 (polar p1 (angle p1 p2) (/ l 2))) 
    ) 
  ) 
) 
(princ "\n删除重叠块 by yjr111 2012-4-4 命令:deldumpk")

taoyi0727 · 发表于 2020-5-30 12:04:55

我的思路
1.获取所有块
2.按块名分类
3.判断每个分类里的图块插入点是否有重复的
4.把重复的删除

lingduwx · 发表于 2020-5-30 12:17:39

顶一个哈哈哈

andyzha · 发表于 2020-5-30 12:19:33

taoyi0727 发表于 2020-5-30 12:04
我的思路
1.获取所有块
2.按块名分类

这个对属性块和动态块就不友好了，很容易误判，特别是拉伸的动态块。

taoyi0727 · 发表于 2020-5-30 14:01:44

andyzha 发表于 2020-5-30 12:19
这个对属性块和动态块就不友好了，很容易误判，特别是拉伸的动态块。

动态块,你拉伸后也不叫重叠了噻
至于属性块就只有单独处理了

andyzha · 发表于 2020-5-31 18:09:56

taoyi0727 发表于 2020-5-30 14:01
动态块,你拉伸后也不叫重叠了噻
至于属性块就只有单独处理了

目前能解决问题的就是现在这个程序，大神能修复一下吗？

andyzha · 发表于 2020-6-1 20:13:53

希望大神能关注解决一下。

andyzha · 发表于 2020-6-3 09:14:22

最近大神比较少出没啊，期待优化。

菜卷鱼 · 发表于 2020-6-8 10:59:17

搞个图来测试一下

oistre · 发表于 2020-6-11 16:53:22

希望大神能关注解决一下。

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

[提问] 重叠块删除程序优化