;;以前写过一个点选图块删除的程序，这次将文字加了进来，做设计难免用到电子版地形图
;;里面无用的信息比较多，典型的就是图块和单个文字
;;适用 AutoCAD 2000+
;;作者： eachy [[url]www.xdcad.net[/url] 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)