Jump to content

Add to Block By Lee Mac

BrianTFC

By BrianTFC
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

BrianTFC Community Regular

BrianTFC

Posted
Posted

All,

 

I was wondering if anyone else was having a problem using Lee Mac's "Add to Block " on a dynamic block? Recently our title blocks have changed over to dynamic and now I cant use "Add to block" anymore.

 

Thanks,

Brian

Lee Mac Grand Master

Lee Mac

Posted
Posted

This program is old and will need to be updated for compatibility with dynamic blocks.

BrianTFC Community Regular

BrianTFC

Posted
  • Author
Posted

Lee,

 

Thank you for the quick response i was just making sure i didn't do anything wrong with my dynamic title blocks.

 

Thanks,

Brian

BrianTFC Community Regular

BrianTFC

Posted
  • Author
Posted

All,

 

So here is our attempt at trying to get Lee Mac's "Add2Block" to use dynamic blocks, it keeps giving us an entity error. Any idea?

 

;;----------------=={ Add Objects to Block }==----------------;;
;;                                                            ;;
;;  Adds all objects in the provided SelectionSet to the      ;;
;;  definition of the specified block.                        ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - [url="http://www.lee-mac.com"]www.lee-mac.com[/url]       ;;
;;------------------------------------------------------------;;
;;  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 - [url="http://www.lee-mac.com"]www.lee-mac.com[/url]       ;;
;;------------------------------------------------------------;;
;;  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 - [url="http://www.lee-mac.com"]www.lee-mac.com[/url]       ;;
;;------------------------------------------------------------;;
;;  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 - [url="http://www.lee-mac.com"]www.lee-mac.com[/url]       ;;
;;------------------------------------------------------------;;
;;  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 - [url="http://www.lee-mac.com"]www.lee-mac.com[/url]       ;;
;;------------------------------------------------------------;;
;;  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 - [url="http://www.lee-mac.com"]www.lee-mac.com[/url]       ;;
;;------------------------------------------------------------;;
;;  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)
   )
 )
 
;------------preliminary start of combine
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (princ "Select objects to add to block: ")
  (setq ss (ssget "_:L"));remove "if" and "and"
;-----------start of combine
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
     (if (and (progn 
              (initget "B")
              (setq ob (entsel "\nSelect Block/B for blockname: "))
                (cond 
                   ((eq ob "B")
                      (setq bn (getstring "\nEnter Block Name: "))
                   );end (eq ob "B")
                    ((and (eq (type ob) 'LIST)
                          ;(vlax-method-applicable-p (vlax-ename->vla-object (car ob)) 'getboundingbox)
                     );end second and
                         ;(vla-get-EffectiveName (vlax-ename->vla-object (car (car (reverse (nentsel))))))
                         ;(setq bn (cdr (assoc 2 (entget (car ob)))));original
                          (setq bn (vla-get-Effectivename (vlax-ename->vla-object (car ob))))
                    );end first and
                   );end cond
                );end progn
 (tblsearch "BLOCK" bn)
               bn 
;-------
                
    (setq ss1 (ssget "_X" (list '(0 . "INSERT")'(410 . "Model")'(-4 . "<OR")(cons 2 bn)(cons 2 "`*U*,")'(-4 . "OR>"))))
    (setq num (sslength ss1)) ; zero counter
    (setq num (1- num))
          (repeat (sslength ss1) ; repeat for the number of objects in the selection set
             (setq ent1 (ssname ss1 num)) ; find the entity name
             (setq effname (vla-get-EffectiveName (vlax-ename->vla-object ent1))) ; Find the EffectiveName of the block
                 (if (/= bn effname) ; if the blockname matches the effective name
                     (ssdel ent1 ss1) ; then delete it from the original selection set
                 ); end if
             (setq num (1- num)) ; Increment the counter by one
          );end repeat
;-----------------------
                     );end and on top
;------------------------------------------------------------------------------------------------
    (progn 
         (vla-zoomextents (vlax-get-acad-object))
             (repeat (setq i (sslength ss1))
             (setq e (ssname ss1 (setq i (1- i))))
             (setq e (vlax-ename->vla-object (ssname ss1 (setq i (1- i)))))
             (_StartUndo acdoc) (LM:AddObjectstoBlock acdoc (car e) ss) (_EndUndo acdoc)
             );end repeat
    );end progn
 (princ "\nNo Blocks Selected: ")
);end if on top
   ;(setvar "cmdecho" cmd)
   ;(setvar "FILEDIA" OldFda) ;sets system variable FILEDIA back to original value
   ;(setvar "EXPERT" Save_Expert) ;sets system variable EXPERT back to original value
;------------end of combine
(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) (_EndUndo acdoc)
 )
 (princ)
)
(vl-load-com) (princ)
;;------------------------------------------------------------;;
;;                         End of File                        ;;
;;------------------------------------------------------------;;

 

Thanks,

Brian

marko_ribar Veteran

marko_ribar

Posted
Posted

Maybe :

 

...
    (progn 
         (vla-zoomextents (vlax-get-acad-object))
             (repeat (setq i (sslength ss1))
             (setq e (ssname ss1 (setq i (1- i))))
             (setq e (vlax-ename->vla-object e))
             (_StartUndo acdoc) (LM:AddObjectstoBlock acdoc e ss) (_EndUndo acdoc)
             );end repeat
    );end progn
...

BrianTFC Community Regular

BrianTFC

Posted
  • Author
Posted

marko_ribar,

 

I tried that now I'm getting an object error..:unsure:

Jef! Rising Star

Jef!

Posted
Posted

To achieve that you need 2 modifications from the original code. These are

That

(vla-CopyObjects doc (LM:SafearrayVariant vlax-vbobject lst)
   (vla-item (vla-get-Blocks doc) [color="red"](cdr (assoc 2 (entget block)))[/color])
 )

need to be swapped for that

(vla-CopyObjects doc (LM:SafearrayVariant vlax-vbobject lst)
   (vla-item (vla-get-Blocks doc) [color="seagreen"](vla-get-effectivename(vlax-ename->vla-object block))[/color])
 )

That will take care of adding the items in all instances of the block that havn't been changed dynamically, so the inserts that still have the same name as the original block definition.

 

After that, all that remain to be done is to get all *U blocks, and if they have the same effective name, their names must be parsed to the same function

(if (ssget "_X" '((0 . "INSERT")(2 . "`*U*")))
       (progn
           (vlax-for o (setq [b]s[/b] (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))))
               (if (= (vla-get-effectivename(vlax-ename->vla-object block)) (vla-get-effectivename o))
                   (vla-CopyObjects doc (LM:SafearrayVariant vlax-vbobject lst)
                     (vla-item (vla-get-Blocks doc) (vla-get-name o))
                   )
               )
           )
         (vla-delete s)
       )
 )

 

As a new variable has been created (s), it must be added to the local variable list of LM:AddObjectstoBlock.

 

Heres the complete code with the modifications made for add2block.

I just added 1 eyebrow to your MonaLisa Lee. Hope you won't mind!? :shock:

 

AddObjectsToBlockV1-1.lsp © 2018 Lee Mac
DarkLightVLIDE
;;----------------=={ 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 s)
 
 (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) (vla-get-effectivename(vlax-ename->vla-object block)))
 )
 (if (ssget "_X" '((0 . "INSERT")(2 . "`*U*")))
       (progn
           (vlax-for o (setq s (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))))
               (if (= (vla-get-effectivename(vlax-ename->vla-object block)) (vla-get-effectivename o))
                   (vla-CopyObjects doc (LM:SafearrayVariant vlax-vbobject lst)
                     (vla-item (vla-get-Blocks doc) (vla-get-name o))
                   )
               )
           )
         (vla-delete s)
       )
 )
 (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) (_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) (_EndUndo acdoc)
 )
 (princ)
)

(vl-load-com) (princ)

;;------------------------------------------------------------;;
;;                         End of File                        ;;
;;------------------------------------------------------------;;

BrianTFC Community Regular

BrianTFC

Posted
  • Author
Posted

Jef!,

 

Thanks that for fixing it, so how do we fix the remove part of the program? I've tried to modify it but it keeps crashing.

 

Thanks,

Brian

  • 2 weeks later...
Jef! Rising Star

Jef!

Posted
Posted
Thanks that for fixing it, so how do we fix the remove part of the program?

There was nothing in your original request about fixing the remove part of the block. Anyhow... Here's the code add2block & remove completely revamped to be used on dynamic blocks. Few points...

  • I have redone the modif that I made earlier and optimized it using a lambda to feed it vla-get-blocks as an argument instead of evaluating it multiple times (I originally made it especially bad by calling it it the vlax-for loop).
  • It allows adding objects on dynamic blocks, independently on whether you select a non modified block insert or a modified one (name *u###)
  • It allows removing from dynamic blocks as well, also independently on whether you select a non modified block insert or a modified one by finding the corresponding entity to remove in each insertions. The corresponding entity being the original object definition without ename, handle and owner (goup codes -1/5/330)
  • It wont allow the removal of dynamically modified entities to avoid ending up with discrepancies between blocks with the same effective name, as not all the inserts contain the same corresponding entities.
  • I added a vla-update call on the inserts modified, as without it, (at least on 2015 I was not able to using the original "add2block" function) even if the block is updated graphically, you would not be able to select the insert by selecting the newly graphically added entity/entities. It is now fixed.
  • I highlighted the code I modified and added for an easy review.

 

I did some testing, all look working. If I forgot anything, or if you have any comments please let me know.

 

Cheers!

 

;;----------------=={ 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       ;;
;;  Updated to work with dynamic blocks by Jef! on 2018-14-26 ;;
;;------------------------------------------------------------;;
;;  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))
[color="seagreen"]  ((lambda ( x / s Uname proclst Effname);added dyn block handling in lambda to make single get-blocks call
    (vla-CopyObjects doc (LM:SafearrayVariant vlax-vbobject lst)
      (vla-item x (setq Effname (vla-get-effectivename(vlax-ename->vla-object block))))
    )
    (if (ssget "_X" (list '(0 . "INSERT")(cons 2 (strcat"`*U*,"Effname))))
          (progn
             (vlax-for o (setq s (vla-get-activeselectionset doc))
               (or
                 (and (= Effname (vla-get-name o))
                      (null (vla-Update o))
                 )
                 (and (not (member (setq Uname (vla-get-name o)) proclst))
                      (setq proclst (cons Uname proclst))
                      (= Effname (vla-get-effectivename o))
                      (vla-CopyObjects doc (LM:SafearrayVariant vlax-vbobject lst) (vla-item x Uname) )
                      (null (vla-Update o))
                 )
                 (and (member (setq Uname (vla-get-name o)) proclst)
                      (null (vla-Update o))
                 )
               )
             )
             (vla-delete s)
          )
    )
  )
  (vla-get-Blocks doc)
 )[/color]
 (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       ;;
;;  Updated to work with dynamic blocks by Jef! on 2018-14-26 ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ent - Entity name of Object to Delete from Block [ENAME]  ;;
;;------------------------------------------------------------;;

;New function by Jef! to work on dynamic blocks
(defun LM:RemovefromBlock ( doc ent [color="seagreen"]ins / ePrtDef NamLst entdef effnam s Uname lst2del itmdef ent2del[/color])
[color="seagreen"]  (setq ePrtDef ((lambda (x) (vl-remove (assoc 330 x)(vl-remove (assoc 5 x) x))
                )
                (cdr (entget ent))
               )
        NamLst (list (vla-get-effectivename (vlax-ename->vla-object ins)))
 )
 (if (ssget "_X" '((0 . "INSERT")(2 . "`*U*")))
     (progn
       (vlax-for o (setq s (vla-get-activeselectionset doc))
         (and (= (last NamLst) (vla-get-effectivename o))
              (not (member (setq Uname (vla-get-name o))NamLst))
              (setq NamLst (cons Uname NamLst))
         )
       )
       (vla-delete s)
     )
 )
 (foreach bnam NamLst
   (setq bnam (tblobjname "block" bnam) ent2del nil)
   (while (and (setq bnam (entnext bnam))
        (not (eq "SEQEND" (cdr (assoc 0 (setq itmdef (entget bnam))))))
               (or (null (vl-every '(lambda ( searchedassoc / )
                                      (member searchedassoc itmdef)
                                    )
                                    ePrtDef
                         )
                   )
                   (null (setq ent2del (cdr (assoc -1 itmdef))))
                 )
      )
   )
   (setq lst2del (cons ent2del lst2del))
 )
 (if (vl-some 'null lst2del)
     (princ"\nYou cannot target a dynamically modified object to be removed")
     (progn
       (foreach obj lst2del
         (vla-delete (vlax-ename->vla-object obj))
       )
       (vla-regen doc acAllViewports)
     )
 )[/color]
 
 (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) (_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 (nentsel "\nSelect Object to Remove: "));[color="seagreen"]was setq e (car(nentsel[/color]
   (_StartUndo acdoc) (LM:RemovefromBlock acdoc (car e)(car(last e))) (_EndUndo acdoc);added argument(car(last e))
 )
 (princ)
)

(vl-load-com) (princ)

;;------------------------------------------------------------;;
;;                         End of File                        ;;
;;------------------------------------------------------------;;

BrianTFC Community Regular

BrianTFC

Posted
  • Author
Posted

Jef!,

 

Thank you for updating the remove part of the lisp it works just like it did before but with dynamic blocks. Maybe Lee will use it to update the one on his web site so everyone else can benefit from it.

 

Brian

Jef! Rising Star

Jef!

Posted
Posted
Thank you for updating the remove part of the lisp it works just like it did before but with dynamic blocks. Maybe Lee will use it to update the one on his web site so everyone else can benefit from it.

 

You are welcome. I must say I'm quite happy that I managed to achieve it (and very efficiently, I think), and I didn't find any way of making it crash :D

As for if Lee will update the one on his site, I sent him a message in that regard. Let's wait and see if he likes his Mona Lisa with 2 eyebrows and m-shaped seagulls in the background. I really hope he does. :)

 

Cheers.

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...