求一个“块添加实体”和“块移出实体”的程序
本帖最后由 微笑忘记过去 于 2014-6-27 14:54 编辑求一个块添加实体和快删除实体的工具，
要求
1、块添加实体：先选择源块，再选择要添加的图元。
2、块移出实体：直接点选要从图块中移出的实体，执行完后被删除的实体仍然保留在图中而不在块中。
Lee-mac的大作不是太好用，求各位大神各显神通哦。
(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)
LeeMac的为什么不好用？
另外请编辑标题，【Gu_xl】前缀是Ｇ版的专属标记， 我还以为G版又出大作了 有大师的作品，能够吸收消化为己所用才是学习之道！ 这个比较有用 帮你顶起来 xyp1964 发表于 2014-6-24 14:06 static/image/common/back.gif
一直在秀，从不共享 探索者2011版本自带就有这个程序的 微笑忘记过去 发表于 2014-10-16 14:30 static/image/common/back.gif
一直在秀，从不共享
饿着肚子看别人吃火锅，那心情~~~~
页:
[1]