[编程交流] 在exis中插入“子”块

;;----------------=={ Add Objects to Block }==----------------;;
;;                                                            ;;
;;  Adds all objects in the provided SelectionSet to the      ;;
;;  definition of the specified block.                        ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  block - Entity name of reference insert                   ;;
;;  ss    - SelectionSet of objects to add to definition      ;;
;;------------------------------------------------------------;;
(defun LM:AddObjectstoBlock ( block ss / ObjLst org doc vector )
 ;; © Lee Mac 2010
 (vl-load-com)
 (setq ObjLst (LM:ss->vla ss) org (vlax-3D-point '(0. 0. 0.)))
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 
 (setq vector
   (vlax-3D-point
     (mapcar '- (cdr (assoc 10 (entget block)))
       (cdr
         (assoc 10
           (entget
             (tblobjname "BLOCK"
               (cdr (assoc 2 (entget block)))
             )
           )
         )
       )
     )
   )
 )
 (mapcar '(lambda ( obj ) (vla-move obj vector org)) ObjLst)
 (vla-CopyObjects (vla-get-ActiveDocument (vlax-get-acad-object))
   (LM:ObjectVariant ObjLst)
   (vla-item (vla-get-Blocks doc)
     (LM:GetBlockName (vlax-ename->vla-object block))
   )
 )
 (LM:ApplyFootoSS (lambda ( x ) (entdel x)) ss)
 (vla-regen doc acAllViewports)
)
;;------------------=={ Safearray Variant }==-----------------;;
;;                                                            ;;
;;  Creates a populated Safearray Variant of a specified      ;;
;;  data type                                                 ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  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 )
 ;; © Lee Mac 2010
 (vlax-make-variant
   (vlax-safearray-fill
     (vlax-make-safearray datatype
       (cons 0 (1- (length data)))
     )
     data
   )    
 )
)
;;-------------------=={ Object Variant }==-------------------;;
;;                                                            ;;
;;  Creates a populated Object Variant                        ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  lst - list of VLA Objects to populate the Variant.        ;;
;;------------------------------------------------------------;;
;;  Returns:  VLA Object Variant                              ;;
;;------------------------------------------------------------;;
(defun LM:ObjectVariant ( lst )
 ;; © Lee Mac 2010
 (LM:SafearrayVariant vlax-vbobject lst)
)
;;-----------------=={ SelectionSet -> VLA }==----------------;;
;;                                                            ;;
;;  Converts a SelectionSet to a list of VLA Objects          ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ss - Valid SelectionSet (Pickset)                         ;;
;;------------------------------------------------------------;;
;;  Returns:  List of VLA Objects                             ;;
;;------------------------------------------------------------;;
(defun LM:ss->vla ( ss )
 ;; © Lee Mac 2010
 (if ss
   (
     (lambda ( i / e l )
       (while (setq e (ssname ss (setq i (1+ i))))
         (setq l (cons (vlax-ename->vla-object e) l))
       )
       l
     )
     -1
   )
 )
)
;;-------------------=={ Get Block Name }==-------------------;;
;;                                                            ;;
;;  Retrieves the Block Name as per the Block Definition      ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  obj - VLA Block Reference Object                          ;;
;;------------------------------------------------------------;;
;;  Returns:  Block Name [sTR]                                ;;
;;------------------------------------------------------------;;
(defun LM:GetBlockName ( obj )
 (vlax-get-property obj
   (if (vlax-property-available-p obj 'EffectiveName)
     'EffectiveName 'Name
   )
 )
)
;;------------------=={ Apply Foo to SS }==-------------------;;
;;                                                            ;;
;;  Applies a function to every entity in a SelectionSet      ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  foo - a function taking one argument (an entity name)     ;;
;;  ss  - valid SelectionSet (pickset)                        ;;
;;------------------------------------------------------------;;
;;  Returns:  Last evaluation of function foo                 ;;
;;------------------------------------------------------------;;
(defun LM:ApplyFootoSS ( foo ss )
 ;; © Lee Mac 2010
 (
   (lambda ( i / e )
     (while (setq e (ssname ss (setq i (1+ i)))) (foo e))
   )
   -1
 )
)
;; Test Function.
(defun c:test ( / ss ent )
 (if (and (setq ss  (ssget "_:L"))
          (setq ent (car (entsel "\nSelect Block: ")))
          (eq "INSERT" (cdr (assoc 0 (entget ent)))))
   (LM:AddObjectstoBlock ent ss)
 )
 (princ)
)
   

;;----------------=={ Add Objects to Block }==----------------;;
;;                                                            ;;
;;  Adds all objects in the provided SelectionSet to the      ;;
;;  definition of the specified block.                        ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  block - Entity name of reference insert                   ;;
;;  ss    - SelectionSet of objects to add to definition      ;;
;;------------------------------------------------------------;;
(defun LM:AddObjectstoBlock ( block ss / ObjLst doc Mat tMat vector )
 ;; © Lee Mac 2010
 (vl-load-com)
 (setq ObjLst (LM:ss->vla ss)
          doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (setq Mat (LM:Geom->Def (vlax-ename->vla-object block)))
 
 (setq vector
   (mapcar '-
     (cdr
       (assoc 10
         (tblsearch "BLOCK" (cdr (assoc 2 (entget block))))
       )
     )
     (mxv Mat
       (trans (cdr (assoc 10 (entget block)))
         (cdr (assoc 210 (entget block))) 0 ; OCS->WCS
       )
     )
   )
 )
 (setq tMat
   (vlax-tmatrix
     (append
       (mapcar 'append mat (mapcar 'list vector)) '((0. 0. 0. 1.))
     )
   )
 )
 (mapcar '(lambda ( obj ) (vla-transformby obj tMat)) ObjLst)
 (vla-CopyObjects doc (LM:ObjectVariant ObjLst)
   (vla-item (vla-get-Blocks doc)
     (LM:GetBlockName (vlax-ename->vla-object block))
   )
 )
 (LM:ApplyFootoSS (lambda ( x ) (entdel x)) ss)
 (vla-regen doc acAllViewports)
)
;;-----------------=={ Remove From Block }==------------------;;
;;                                                            ;;
;;  Removes an Entity from a Block Definition                 ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ent - Entity name of Object to Delete from Block [ENAME]  ;;
;;------------------------------------------------------------;;
(defun LM:RemovefromBlock ( ent )
 ;; © Lee Mac 2010
 (vl-load-com)
 
 (vla-Delete (vlax-ename->vla-object ent))
 (vla-regen
   (vla-get-ActiveDocument (vlax-get-acad-object)) acAllViewports
 )
)
;;------------------=={ Safearray Variant }==-----------------;;
;;                                                            ;;
;;  Creates a populated Safearray Variant of a specified      ;;
;;  data type                                                 ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  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 )
 ;; © Lee Mac 2010
 (vlax-make-variant
   (vlax-safearray-fill
     (vlax-make-safearray datatype
       (cons 0 (1- (length data)))
     )
     data
   )    
 )
)
;;-------------------=={ Object Variant }==-------------------;;
;;                                                            ;;
;;  Creates a populated Object Variant                        ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  lst - list of VLA Objects to populate the Variant.        ;;
;;------------------------------------------------------------;;
;;  Returns:  VLA Object Variant                              ;;
;;------------------------------------------------------------;;
(defun LM:ObjectVariant ( lst )
 ;; © Lee Mac 2010
 (LM:SafearrayVariant vlax-vbobject lst)
)
;;-----------------=={ SelectionSet -> VLA }==----------------;;
;;                                                            ;;
;;  Converts a SelectionSet to a list of VLA Objects          ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ss - Valid SelectionSet (Pickset)                         ;;
;;------------------------------------------------------------;;
;;  Returns:  List of VLA Objects                             ;;
;;------------------------------------------------------------;;
(defun LM:ss->vla ( ss )
 ;; © Lee Mac 2010
 (if ss
   (
     (lambda ( i / e l )
       (while (setq e (ssname ss (setq i (1+ i))))
         (setq l (cons (vlax-ename->vla-object e) l))
       )
       l
     )
     -1
   )
 )
)
;;-------------------=={ Get Block Name }==-------------------;;
;;                                                            ;;
;;  Retrieves the Block Name as per the Block Definition      ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  obj - VLA Block Reference Object                          ;;
;;------------------------------------------------------------;;
;;  Returns:  Block Name [sTR]                                ;;
;;------------------------------------------------------------;;
(defun LM:GetBlockName ( obj )
 (vlax-get-property obj
   (if (vlax-property-available-p obj 'EffectiveName)
     'EffectiveName 'Name
   )
 )
)
;;------------------=={ Apply Foo to SS }==-------------------;;
;;                                                            ;;
;;  Applies a function to every entity in a SelectionSet      ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  foo - a function taking one argument (an entity name)     ;;
;;  ss  - valid SelectionSet (pickset)                        ;;
;;------------------------------------------------------------;;
;;  Returns:  Last evaluation of function foo                 ;;
;;------------------------------------------------------------;;
(defun LM:ApplyFootoSS ( foo ss )
 ;; © Lee Mac 2010
 (
   (lambda ( i / e )
     (while (setq e (ssname ss (setq i (1+ i)))) (foo e))
   )
   -1
 )
)
;;---------------------=={ Geom->Def }==----------------------;;
;;                                                            ;;
;;  Returns the Transformation Matrix for transforming Block  ;;
;;  Geometry to the Block Definiton.                          ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, June 2010                          ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  SourceBlock - VLA Block Reference Object                  ;;
;;------------------------------------------------------------;;
;;  Returns:  A 3x3 Transformation Matrix                     ;;
;;------------------------------------------------------------;;
(defun LM:Geom->Def ( SourceBlock / norm ang x y z )
 ;; © Lee Mac  ~  11.06.10
 (vl-load-com)
 (setq norm (vlax-get SourceBlock 'Normal)
        ang (- (vla-get-rotation SourceBlock)))
     
 (mapcar 'set '(x y z)
   (mapcar
     '(lambda ( prop alt )
        (/ 1.
           (vlax-get-property SourceBlock
             (if (vlax-property-available-p SourceBlock prop) prop alt)
           )
         )
      )
     '(XEffectiveScaleFactor YEffectiveScaleFactor ZEffectiveScaleFactor)
     '(XScaleFactor          YScaleFactor          ZScaleFactor         )
   )
 )
 (mxm
   (list
     (list x 0. 0.)
     (list 0. y 0.)
     (list 0. 0. z)
   )
   (mxm
     (list
       (list (cos ang) (sin (- ang)) 0.)
       (list (sin ang) (cos ang)     0.)
       (list     0.        0.        1.)
     )
     (mapcar '(lambda ( e ) (trans e norm 0 t)) ; OCS->WCS
       '((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)))
;; -- Test Functions --
(defun c:Add ( / *error* doc undo ss ent )
 (vl-load-com)
 ;; © Lee Mac 2010
 (defun *error* ( msg )
   (and undo (vla-EndUndomark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (and (setq ss  (ssget "_:L"))
          (setq ent (car (entsel "\nSelect Block: ")))
          (eq "INSERT" (cdr (assoc 0 (entget ent)))))
   (progn
     (setq undo (not (vla-StartUndoMark doc)))
     (LM:AddObjectstoBlock ent ss)
     (setq undo (vla-EndUndoMark doc))
   )
 )
 (princ)
)
;-------------------------------------------------------------
(defun c:Remove ( / *error* doc undo ss )
 (vl-load-com)
 ;; © Lee Mac 2010
 (defun *error* ( msg )
   (and undo (vla-EndUndomark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (setq ss (ssget "_:N"))
   (progn
     (setq undo (not (vla-StartUndoMark doc)))
     
     (mapcar 'LM:RemovefromBlock
       (vl-remove-if 'listp
         (mapcar 'cadr (ssnamex ss))
       )
     )
     
     (setq undo (vla-EndUndoMark doc))
   )
 )
 (princ)
)