块增加对象

dingwqing · 发表于 2015-6-19 14:15

回复，下载，学习！！！！！

王与韩1 · 发表于 2015-6-19 15:51

看看什么东西

小师傅 · 发表于 2015-6-26 12:16

学习大师作品

风流少年时 · 发表于 2015-6-26 12:33

看看东西先。

etoxp · 发表于 2015-6-26 12:41

学习一下。。。。。。。。。。。。。

nadaloveluna · 发表于 2015-6-26 16:22

黄工又出新作了，哈哈哈，谢谢啦。

edata · 发表于 2015-6-27 11:23

块中添加对象LEE-MAC的修改，解决无法框选问题。
entmake方式有问题，会更改block的句柄组码，而vla方式不会，
CAD04 08 11测试通过

;;----------------=={ Add Objects to Block }==----------------;;
;; ;;
;; Adds all objects in the provided SelectionSet to the ;;
;; definition of the specified block. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; doc - Document Object in which block resides. ;;
;; block - Entity name of reference insert ;;
;; ss - SelectionSet of objects to add to definition ;;
;;------------------------------------------------------------;;
(defun LM:AddObjectstoBlock ( doc block ss / lst mat )
(setq lst (LM:ss->vla ss)
mat (LM:Ref->Def block)
mat (vlax-tmatrix (append (mapcar 'append (car mat) (mapcar 'list (cadr mat))) '((0. 0. 0. 1.))))
)
(foreach obj lst (vla-transformby obj mat))
(vla-CopyObjects doc (LM:SafearrayVariant vlax-vbobject lst)
(vla-item (vla-get-Blocks doc) (cdr (assoc 2 (entget block))))
)
(foreach obj lst (vla-delete obj))
(vla-regen doc acAllViewports)
)
;;-----------------=={ Remove From Block }==------------------;;
;; ;;
;; Removes an Entity from a Block Definition ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; ent - Entity name of Object to Delete from Block [ENAME] ;;
;;------------------------------------------------------------;;
(defun LM:RemovefromBlock ( doc ent )
(vla-delete (vlax-ename->vla-object ent))
(vla-regen doc acAllViewports)
(princ)
)
;;------------------=={ Safearray Variant }==-----------------;;
;; ;;
;; Creates a populated Safearray Variant of a specified ;;
;; data type ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; datatype - variant type enum (eg vlax-vbDouble) ;;
;; data - list of static type data ;;
;;------------------------------------------------------------;;
;; Returns: VLA Variant Object of type specified ;;
;;------------------------------------------------------------;;
(defun LM:SafearrayVariant ( datatype data )
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray datatype (cons 0 (1- (length data)))) data
)
)
)
;;------------=={ SelectionSet -> VLA Objects }==-------------;;
;; ;;
;; Converts a SelectionSet to a list of VLA Objects ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; ss - Valid SelectionSet (Pickset) ;;
;;------------------------------------------------------------;;
;; Returns: List of VLA Objects, else nil ;;
;;------------------------------------------------------------;;
(defun LM:ss->vla ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
)
)
;;---------------=={ Block Ref -> Block Def }==---------------;;
;; ;;
;; Returns the Transformation Matrix and Translation Vector ;;
;; for transforming Block Reference Geometry to the Block ;;
;; Definiton. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; e - Block Reference Entity ;;
;;------------------------------------------------------------;;
;; Returns: List of 3x3 Transformation Matrix, Vector ;;
;;------------------------------------------------------------;;
(defun LM:Ref->Def ( e / _dxf a l n )
(defun _dxf ( x l ) (cdr (assoc x l)))
(setq l (entget e) a (- (_dxf 50 l)) n (_dxf 210 l))
(
(lambda ( m )
(list m
(mapcar '- (_dxf 10 (tblsearch "BLOCK" (_dxf 2 l)))
(mxv m
(trans (_dxf 10 l) n 0)
)
)
)
)
(mxm
(list
(list (/ 1. (_dxf 41 l)) 0. 0.)
(list 0. (/ 1. (_dxf 42 l)) 0.)
(list 0. 0. (/ 1. (_dxf 43 l)))
)
(mxm
(list
(list (cos a) (sin (- a)) 0.)
(list (sin a) (cos a) 0.)
(list 0. 0. 1.)
)
(mapcar '(lambda ( e ) (trans e n 0 t))
'(
(1. 0. 0.)
(0. 1. 0.)
(0. 0. 1.)
)
)
)
)
)
)
;; Matrix x Vector - Vladimir Nesterovsky
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
;; Matrix x Matrix - Vladimir Nesterovsky
(defun mxm ( m q )
(mapcar (function (lambda ( r ) (mxv (trp q) r))) m)
)
;; Matrix Transpose - Doug Wilson
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;;---------------------=={ Select if }==----------------------;;
;; ;;
;; Provides continuous selection prompts until either a ;;
;; predicate function is validated or a keyword is supplied. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; msg - prompt string ;;
;; pred - optional predicate function [selection list arg] ;;
;; func - selection function to invoke ;;
;; keyw - optional initget argument list ;;
;;------------------------------------------------------------;;
;; Returns: Entity selection list, keyword, or nil ;;
;;------------------------------------------------------------;;
(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))
(while
(progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nMissed, Try again.")
)
( (eq 'STR (type sel))
nil
)
( (vl-consp sel)
(if (and pred (not (pred sel)))
(princ "\nInvalid Object Selected.")
)
)
)
)
)
sel
)
;-------------------------------------------------------------;
; -- Test Functions -- ;
;-------------------------------------------------------------;
(defun c:Add2Block ( / *error* _StartUndo _EndUndo acdoc ss e )
(defun *error* ( msg )
(if acdoc (_EndUndo acdoc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
(defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
)
(defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(if
(and (setq ss (ssget "_:L"))
(setq e
(LM:SelectIf "\nSelect Block to Add Objects to: "
'(lambda ( x ) (eq "INSERT" (cdr (assoc 0 (entget (car x)))))) entsel nil
)
)
)
(progn
(_StartUndo acdoc) (LM:AddObjectstoBlock acdoc (car e) ss)(LM:entupdInsert (car e)) (_EndUndo acdoc)
)
)
(princ)
)
;-------------------------------------------------------------;
(defun c:Remove ( / *error* _StartUndo _EndUndo acdoc e )
(defun *error* ( msg )
(if acdoc (_EndUndo acdoc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
(defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
)
(defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(while (setq e (car (nentsel "\nSelect Object to Remove: ")))
(_StartUndo acdoc) (LM:RemovefromBlock acdoc e)(LM:entupdInsert (car e)) (_EndUndo acdoc)
)
(princ)
)
(vl-load-com) (princ)
;;------------------------------------------------------------;;
;; End of File ;;
;;------------------------------------------------------------;;
;;------------------------------------------------------------;;
;; Modify by edata@mjtd ;;
;;------------------------------------------------------------;;
;;Entupd insert object 2015-6-27
(defun LM:entupdInsert(blk / ss1 en)
(setq ss1(ssget "x" (list '(0 . "insert")(cons 2 (cdr(assoc 2(entget blk)))))))
(while (setq en(ssname ss1 0))
(entupd en)
(setq ss1 (ssdel en ss1))
)
(princ)
)
;;End Modify

;;----------------=={ Add Objects to Block }==----------------;; 
;;                                                            ;; 
;;  Adds all objects in the provided SelectionSet to the      ;; 
;;  definition of the specified block.                        ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ? 2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  doc   - Document Object in which block resides.           ;; 
;;  block - Entity name of reference insert                   ;; 
;;  ss    - SelectionSet of objects to add to definition      ;; 
;;------------------------------------------------------------;; 
 
(defun LM:AddObjectstoBlock ( doc block ss / lst mat ) 
   
  (setq lst (LM:ss->vla ss) 
        mat (LM:Ref->Def block) 
        mat (vlax-tmatrix (append (mapcar 'append (car mat) (mapcar 'list (cadr mat))) '((0. 0. 0. 1.)))) 
  ) 
  (foreach obj lst (vla-transformby obj mat)) 
 
  (vla-CopyObjects doc (LM:SafearrayVariant vlax-vbobject lst) 
    (vla-item (vla-get-Blocks doc) (cdr (assoc 2 (entget block)))) 
  ) 
  (foreach obj lst (vla-delete obj)) 
  (vla-regen doc acAllViewports) 
) 
 
;;-----------------=={ Remove From Block }==------------------;; 
;;                                                            ;; 
;;  Removes an Entity from a Block Definition                 ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ? 2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  ent - Entity name of Object to Delete from Block [ENAME]  ;; 
;;------------------------------------------------------------;; 
 
(defun LM:RemovefromBlock ( doc ent ) 
  (vla-delete (vlax-ename->vla-object ent)) 
  (vla-regen doc acAllViewports) 
  (princ) 
) 
 
;;------------------=={ Safearray Variant }==-----------------;; 
;;                                                            ;; 
;;  Creates a populated Safearray Variant of a specified      ;; 
;;  data type                                                 ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ? 2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  datatype - variant type enum (eg vlax-vbDouble)           ;; 
;;  data     - list of static type data                       ;; 
;;------------------------------------------------------------;; 
;;  Returns:  VLA Variant Object of type specified            ;; 
;;------------------------------------------------------------;; 
                         
(defun LM:SafearrayVariant ( datatype data ) 
  (vlax-make-variant 
    (vlax-safearray-fill 
      (vlax-make-safearray datatype (cons 0 (1- (length data)))) data 
    )    
  ) 
) 
 
;;------------=={ SelectionSet -> VLA Objects }==-------------;; 
;;                                                            ;; 
;;  Converts a SelectionSet to a list of VLA Objects          ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ? 2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  ss - Valid SelectionSet (Pickset)                         ;; 
;;------------------------------------------------------------;; 
;;  Returns:  List of VLA Objects, else nil                   ;; 
;;------------------------------------------------------------;; 
 
(defun LM:ss->vla ( ss / i l ) 
  (if ss 
    (repeat (setq i (sslength ss)) 
      (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l)) 
    ) 
  ) 
) 
 
;;---------------=={ Block Ref -> Block Def }==---------------;; 
;;                                                            ;; 
;;  Returns the Transformation Matrix and Translation Vector  ;; 
;;  for transforming Block Reference Geometry to the Block    ;; 
;;  Definiton.                                                ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ? 2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  e - Block Reference Entity                                ;; 
;;------------------------------------------------------------;; 
;;  Returns:  List of 3x3 Transformation Matrix, Vector       ;; 
;;------------------------------------------------------------;; 
 
(defun LM:Ref->Def ( e / _dxf a l n ) 
 
  (defun _dxf ( x l ) (cdr (assoc x l))) 
 
  (setq l (entget e) a (- (_dxf 50 l)) n (_dxf 210 l)) 
  ( 
    (lambda ( m ) 
      (list m 
        (mapcar '- (_dxf 10 (tblsearch "BLOCK" (_dxf 2 l))) 
          (mxv m 
            (trans (_dxf 10 l) n 0) 
          ) 
        ) 
      ) 
    ) 
    (mxm 
      (list 
        (list (/ 1. (_dxf 41 l)) 0. 0.) 
        (list 0. (/ 1. (_dxf 42 l)) 0.) 
        (list 0. 0. (/ 1. (_dxf 43 l))) 
      ) 
      (mxm 
        (list 
          (list (cos a) (sin (- a)) 0.) 
          (list (sin a) (cos a)     0.) 
          (list    0.        0.     1.) 
        ) 
        (mapcar '(lambda ( e ) (trans e n 0 t)) 
         '( 
            (1. 0. 0.) 
            (0. 1. 0.) 
            (0. 0. 1.) 
          ) 
        ) 
      ) 
    ) 
  ) 
) 
 
;; Matrix x Vector  -  Vladimir Nesterovsky 
(defun mxv ( m v ) 
  (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m) 
) 
 
;; Matrix x Matrix  -  Vladimir Nesterovsky 
(defun mxm ( m q ) 
  (mapcar (function (lambda ( r ) (mxv (trp q) r))) m) 
) 
 
;; Matrix Transpose  -  Doug Wilson 
(defun trp ( m ) 
  (apply 'mapcar (cons 'list m)) 
) 
 
;;---------------------=={ Select if }==----------------------;; 
;;                                                            ;; 
;;  Provides continuous selection prompts until either a      ;; 
;;  predicate function is validated or a keyword is supplied. ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ? 2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  msg  - prompt string                                      ;; 
;;  pred - optional predicate function [selection list arg]   ;; 
;;  func - selection function to invoke                       ;; 
;;  keyw - optional initget argument list                     ;; 
;;------------------------------------------------------------;; 
;;  Returns:  Entity selection list, keyword, or nil          ;; 
;;------------------------------------------------------------;; 
 
(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))   
  (while 
    (progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg)) 
      (cond 
        ( (= 7 (getvar 'ERRNO)) 
 
          (princ "\nMissed, Try again.") 
        ) 
        ( (eq 'STR (type sel)) 
 
          nil 
        ) 
        ( (vl-consp sel) 
 
          (if (and pred (not (pred sel))) 
            (princ "\nInvalid Object Selected.") 
          ) 
        ) 
      ) 
    ) 
  ) 
  sel 
) 
 
;-------------------------------------------------------------; 
;                   -- Test Functions --                      ; 
;-------------------------------------------------------------; 
 
(defun c:Add2Block ( / *error* _StartUndo _EndUndo acdoc ss e ) 
 
  (defun *error* ( msg ) 
    (if acdoc (_EndUndo acdoc)) 
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") 
        (princ (strcat "\n** Error: " msg " **"))) 
    (princ) 
  ) 
 
  (defun _StartUndo ( doc ) (_EndUndo doc) 
    (vla-StartUndoMark doc) 
  ) 
 
  (defun _EndUndo ( doc ) 
    (if (= 8 (logand 8 (getvar 'UNDOCTL))) 
      (vla-EndUndoMark doc) 
    ) 
  ) 
   
  (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))) 
 
  (if 
    (and (setq ss (ssget "_:L")) 
      (setq e 
        (LM:SelectIf "\nSelect Block to Add Objects to: " 
         '(lambda ( x ) (eq "INSERT" (cdr (assoc 0 (entget (car x)))))) entsel nil 
        ) 
      ) 
          
    ) 
    (progn 
      (_StartUndo acdoc) (LM:AddObjectstoBlock acdoc (car e) ss)(LM:entupdInsert (car e)) (_EndUndo acdoc) 
    ) 
  ) 
  (princ) 
) 
 
;-------------------------------------------------------------; 
 
(defun c:Remove ( / *error* _StartUndo _EndUndo acdoc e ) 
 
  (defun *error* ( msg ) 
    (if acdoc (_EndUndo acdoc)) 
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") 
        (princ (strcat "\n** Error: " msg " **"))) 
    (princ) 
  ) 
 
  (defun _StartUndo ( doc ) (_EndUndo doc) 
    (vla-StartUndoMark doc) 
  ) 
 
  (defun _EndUndo ( doc ) 
    (if (= 8 (logand 8 (getvar 'UNDOCTL))) 
      (vla-EndUndoMark doc) 
    ) 
  ) 
   
  (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))) 
 
  (while (setq e (car (nentsel "\nSelect Object to Remove: "))) 
    (_StartUndo acdoc) (LM:RemovefromBlock acdoc e)(LM:entupdInsert (car e)) (_EndUndo acdoc) 
  ) 
  (princ) 
) 
 
(vl-load-com) (princ) 
 
;;------------------------------------------------------------;; 
;;                         End of File                        ;; 
;;------------------------------------------------------------;; 
 
 
;;------------------------------------------------------------;; 
;;                         Modify by edata@mjtd               ;; 
;;------------------------------------------------------------;; 
;;Entupd insert object 2015-6-27 
(defun LM:entupdInsert(blk / ss1 en) 
   (setq ss1(ssget "x" (list '(0 . "insert")(cons 2 (cdr(assoc 2(entget blk))))))) 
  (while (setq en(ssname ss1 0)) 
    (entupd en)    
    (setq ss1 (ssdel en ss1)) 
    ) 
  (princ) 
  ) 
;;End Modify

自贡黄明儒 · 发表于 2015-6-27 13:58

edata 发表于 2015-6-27 11:23
块中添加对象LEE-MAC的修改，解决无法框选问题。
entmake方式有问题，会更改block的句柄组码，而vla方式不 ...

你主要加了个entupd ，就解决问题了？

ucuc2003 · 发表于 2015-6-30 10:07

什么土办法，瞧瞧

Q1241274614 · 发表于 2015-7-6 13:14

提示: 该帖被管理员或版主屏蔽

账号		自动登录	找回密码
密码			注册

[讨论] 块增加对象

点评

评分

点评

Q1241274614 Q1241274614 当前离线积分 2886 明经币个注册时间 2010-10-28 在线时间小时威望金钱个贡献激情	发表于 2015-7-6 13:14 \| 显示全部楼层提示: 该帖被管理员或版主屏蔽

	回复支持反对使用道具举报显身卡