社区 › AutoLISP/Visual LISP 编程技术 › 重叠块删除程序优化

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 n0
      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
      (ifpt
      (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 pte1))))
      (command "_.circle" pt (* 0.55 l));;;画标记圆
      )
      (progn
      (cond((> l 0)
            (setq ep_lst(append ep_lst (list(list p10e1))))
            (command "_.circle" p10 (* 0.55 l));;;画标记圆
         )
         ((= l 0)
      (alert"\n你好运气，发现点块!")
      (setq ep_lst(append ep_lst (list(list p10e1))))
            (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")
    (setqkey (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 nep_lst1))(cadr(nth nep_lst2))) ""
      (if ep_lst1(car(nth nep_lst1))(car(nth nep_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 nep_lst1))(car(nth nep_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

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

查看完整版本: 重叠块删除程序优化