求一个“块添加实体”和“块移出实体”的程序

微笑忘记过去

求一个块添加实体和快删除实体的工具，
要求
1、块添加实体：先选择源块，再选择要添加的图元。
2、块移出实体：直接点选要从图块中移出的实体，执行完后被删除的实体仍然保留在图中而不在块中。
Lee-mac的大作不是太好用，求各位大神各显神通哦。

xyp1964

xiaobaixiaobu

(defun c:c2x ( / *error* acd app dbx def doc dwg dwl ent enx err inc lst mat obj sel vrs xrl )

    (defun *error* ( msg )
        (if (and (= 'vla-object (type dbx)) (not (vlax-object-released-p dbx)))
            (vlax-release-object dbx)
        )
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

    (while (setq def (tblnext "block" (null def)))
        (if (= 4 (logand 4 (cdr (assoc 70 def))))
            (setq xrl (vl-list* "," (cdr (assoc 2 def)) xrl))
        )
    )
    (cond
        (   (= 1 (getvar 'xloadctl))
            (princ "\nXLOADCTL system variable is set to 1, xref source drawings are locked.")
        )
        (   (not
                (and
                    (setq sel
                        (LM:ssget "\nSelect objects to copy to xref: "
                            (list "_:L"
                                (list
                                   '(0 . "~VIEWPORT")
                                   '(-4 . "<NOT")
                                       '(-4 . "<AND")
                                           '(0 . "INSERT") (cons 2 (apply 'strcat (cdr xrl)))
                                       '(-4 . "AND>")
                                   '(-4 . "NOT>")
                                    (if (= 1 (getvar 'cvport))
                                        (cons 410 (getvar 'ctab))
                                       '(410 . "Model")
                                    )
                                )
                            )
                        )
                    )
                    (progn
                        (while
                            (progn (setvar 'errno 0) (setq ent (car (entsel "\nSelect xref: ")))
                                (cond
                                    (   (= 7 (getvar 'errno))
                                        (princ "\nMissed, try again.")
                                    )
                                    (   (= 'ename (type ent))
                                        (if (or (/= "INSERT" (cdr (assoc 0 (setq enx (entget ent)))))
                                                (not (member (cdr (assoc 2 enx)) xrl))
                                            )
                                            (princ "\nSelected object is not an xref.")
                                        )
                                    )
                                )
                            )
                        )
                        ent
                    )
                )
            )
        )
        (   (progn
               (setq dbx
                   (vl-catch-all-apply 'vla-getinterfaceobject
                       (list (setq app (vlax-get-acad-object))
                           (if (< (setq vrs (atoi (getvar 'acadver))) 16)
                               "objectdbx.axdbdocument" (strcat "objectdbx.axdbdocument." (itoa vrs))
                           )
                       )
                   )
               )
               (or (null dbx) (vl-catch-all-error-p dbx))
            )
            (prompt "\nUnable to interface with ObjectDBX.")
        )
        (   (not
                (and
                    (setq dwg (cdr (assoc 1 (tblsearch "block" (cdr (assoc 2 enx))))))
                    (setq dwg (findfile dwg))
                )
            )
            (prompt "\nUnable to locate xref source drawing.")
        )
        (   (progn
                (vlax-for doc (vla-get-documents app)
                    (setq dwl (cons (cons (strcase (vla-get-fullname doc)) doc) dwl))
                )
                (not
                    (or (setq doc (cdr (assoc (strcase dwg) dwl)))
                        (and (not (vl-catch-all-error-p (setq err (vl-catch-all-apply 'vla-open (list dbx dwg)))))
                             (setq doc dbx)
                        )
                    )
                )
            )
            (prompt (strcat "\nUnable to interface with xref source drawing:\n" (vl-catch-all-error-message err)))
        )
        (   (setq mat (revrefgeom ent)
                  mat (vlax-tmatrix (append (mapcar 'append (car mat) (mapcar 'list (cadr mat))) '((0.0 0.0 0.0 1.0))))
                  acd (vla-get-activedocument app)
            )
            (repeat (setq inc (sslength sel))
                (setq obj (vlax-ename->vla-object (ssname sel (setq inc (1- inc))))
                      lst (cons obj lst)
                )
                (vla-transformby obj mat)
            )
            (vlax-invoke acd 'copyobjects lst (vla-get-modelspace doc))
            (vla-saveas doc dwg)
            (vla-reload (vla-item (vla-get-blocks acd) (cdr (assoc 2 enx))))
            (foreach obj lst (vla-delete obj)) ;; Comment this line to retain original objects
        )
    )
    (if (and (= 'vla-object (type dbx)) (not (vlax-object-released-p dbx)))
        (vlax-release-object dbx)
    )
    (princ)
)



(defun LM:ssget ( msg params / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget params))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)



(defun revrefgeom ( ent / ang enx mat ocs )
    (setq enx (entget ent)
          ang (cdr (assoc 050 enx))
          ocs (cdr (assoc 210 enx))
    )
    (list
        (setq mat
            (mxm
                (list
                    (list (/ 1.0 (cdr (assoc 41 enx))) 0.0 0.0)
                    (list 0.0 (/ 1.0 (cdr (assoc 42 enx))) 0.0)
                    (list 0.0 0.0 (/ 1.0 (cdr (assoc 43 enx))))
                )
                (mxm
                    (list
                        (list (cos ang)     (sin ang) 0.0)
                        (list (- (sin ang)) (cos ang) 0.0)
                       '(0.0 0.0 1.0)
                    )
                    (mapcar '(lambda ( v ) (trans v ocs 0 t))
                        '(
                             (1.0 0.0 0.0)
                             (0.0 1.0 0.0)
                             (0.0 0.0 1.0)
                         )
                    )
                )
            )
        )
        (mapcar '- (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
            (mxv mat (trans (cdr (assoc 10 enx)) ocs 0))
        )
    )
)



(defun trp ( m )
    (apply 'mapcar (cons 'list m))
)



(defun mxm ( m n )
    ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)



(defun mxv ( m v )
    (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

;;----------------------------------------------------------------------;;

(vl-load-com)
(princ
    (strcat
        "\n:: Version 1.2 | \\U+00A9  "
        (menucmd "m=$(edtime,0,yyyy)")
        " XXXXXXX::"
        "\n:: Type \"c2x\" to Invoke ::"
    )
)
(princ)

lucas_3333

LeeMac的为什么不好用？　
另外请编辑标题，【Gu_xl】前缀是Ｇ版的专属标记，

bzhjl

我还以为G版又出大作了

Gu_xl

有大师的作品，能够吸收消化为己所用才是学习之道！

bikeboy

这个比较有用 帮你顶起来

微笑忘记过去

xyp1964 发表于 2014-6-24 14:06

一直在秀，从不共享

keke20110916

探索者2011版本自带就有这个程序的                                         

77077

微笑忘记过去 发表于 2014-10-16 14:30
一直在秀，从不共享

饿着肚子看别人吃火锅，那心情~~~~