[原创]：按点选图块或文字删除相同实体

eachy

[PHP]
;;以前写过一个点选图块删除的程序，这次将文字加了进来，做设计难免用到电子版地形图
;;里面无用的信息比较多，典型的就是图块和单个文字
;;适用 AutoCAD 2000+
;;作者： eachy [www.xdcad.net 2005.11.1
(vl-load-com)
(defun c:Del_blk_txt (/            blklst txtlst e         el        typ    bn     str
             filter ss           e          ssl         txt        n      thisdrawing
             myerr  fl           fltxt  flblk         s1
            )
  (defun myerr (msg)
    (if        (/= msg "Cancel")
      (princ "\n*取消*")
    )
    (vla-endundomark thisdrawing)
    (setq *error* olderr)
    (princ)
  )
  (while
    (and (progn
           (if blklst
             (progn
               (princ "\n已选择图块")
               (princ (vl-princ-to-string blklst))
             )
           )
           (if txtlst
             (progn
               (princ "\n已选择文字: ")
               (princ (vl-princ-to-string
                        (mapcar        '(lambda (x) (vl-string-trim "*" x))
                                txtlst
                        )
                      )
               )
             )
           )
           t
         )
         (setq e (car (entsel "\n点选样本图块或文字: ")))
         (setq el (entget e))
         (wcmatch (setq typ (cdr (assoc 0 el))) "INSERT,*TEXT")
    )
     (if (= typ "INSERT")
       (if blklst
         (if (member (setq bn (cdr (assoc 2 el))) blklst)
           (setq blklst (vl-remove bn blklst))
           (setq blklst (cons bn blklst))
         )
         (setq blklst (cons (cdr (assoc 2 el)) blklst))
       )
       (progn
         (setq str (cdr (assoc 1 el)))
         (if (/= (strlen str) (strlen (vl-string-trim " " str)))
           (setq str (strcat "*" (vl-string-trim " " str) "*"))
         )
         (if txtlst
           (if (member str txtlst)
             (setq txtlst (vl-remove str txtlst))
             (setq txtlst (cons str txtlst))
           )
           (setq txtlst (cons str txtlst))
         )
       )
     )
  )
  (setq        olderr        *error*
        *error*        myerr
  )
  (vla-startundomark
    (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
  )
  (if (or blklst txtlst)
    (progn
      (if blklst
        (setq flblk (vl-string-translate
                      " "
                      ","
                      (vl-princ-to-string
                        (mapcar        '(lambda (x)
                                   (if (= (substr x 1 1) "*")
                                     (strcat "`" x)
                                     x
                                   )
                                 )
                                blklst
                        )
                      )
                    )
              flblk (vl-string-trim "()" flblk)
        )
      )
      (if txtlst
        (setq fltxt  (vl-string-translate
                       " "
                       ","
                       (vl-princ-to-string txtlst)
                     )
              fltxt  (vl-string-trim "()" fltxt)
              txtlst (mapcar '(lambda (x) (vl-string-trim "*" x)) txtlst)
        )
      )
      (cond
        ((and fltxt flblk)
         (setq fl (list        '(-4 . "<or")
                        (cons 2 flblk)
                        (cons 1 fltxt)
                        '(-4 . "or>")
                  )
         )
        )
        (fltxt
         (setq fl (list (cons 1 fltxt)))
        )
        (flblk
         (setq fl (list (cons 2 flblk)))
        )
        (t)
      )
      (princ "\n选择删除范围<回车全选>....")
      (if (not (setq ss (ssget fl)))
        (setq ss (ssget "x" fl))
      )
      (if ss
        (progn
          (if blklst
            (progn
              (if (setq s1 (ssget "_p" (list (cons 2 flblk))))
                (vl-cmdf ".erase" s1 "")
              )
            )
          )
          (if txtlst
            (progn
              (command ".select" ss "")
              (if (setq s1 (ssget "_P" (list (cons 1 fltxt))))
                (progn
                  (setq        ssl (sslength s1)
                        n   0
                  )
                  (repeat ssl
                    (setq e   (ssname s1 n)
                          n   (1+ n)
                          txt (cdr (assoc 1 (entget e)))
                    )
                    (if        (vl-position (vl-string-trim " " txt) txtlst)
                      (entdel e)
                    )
                  )
                )
              )
            )
          )
        )
      )
    )
  )
  (vla-endundomark thisdrawing)
  (setq *error* olderr)
  (princ)
)
(princ "\nStart Command with Del_blk_txt. eachy[www.xdcad.net]")
(princ)[/PHP]

xdcad9819

学习学习学习学习学习学习学习学习学习学习

xdcad9819

对文字有效