Replace block with block

[Flacon]

Good afternoon, this is quite a tricky one to explain, but ill give it a shot. The company I work for is after a fully automated process to substitute out block on a .dwg for another block on a different .dwg (a block library essentially). I have very basic LISP know how and have inherited a script from a previous experienced user.

 

I need a LISP routine that will detect the items within a block, for example, does the block contain a circle and a piece of text, if so, grab this specific block from this drawing and replace the current block with the new one. As i said, this should require no user input other than the running of the script.

 

in pseudo code

-user runs script

-do any blocks on page contain circle and text?

-if so, fetch a block from other drawing and replace the block

-if not...

-do any blocks on page contain a hatch and 3 lines

-if so, fetch a block from other drawing and replace the block

...and so on until all the blocks are replaced.

 

I appreciate this may be a strange one, but the only intelligent attribute we can use to substitute blocks are the contents of the blocks themselves.

 

Thanks in advance.

[devitg]

@Flacon Try to search about ODBX, lee mac has some tips 

 

Lee Mac ODBX

[Steven P]

Do the blocks have the same names, something like this offering from Lee Mac might work: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/update-blocks-amp-attributes-lisp/td-p/4399069 - search for redefining Blocks. For this the blocks are in a directory, each block saved as its own file (which is how I prefer to save them).

 

or do the new and old blocks have different names? Not sure if something like Lee Macs Steal LISP will do that?

 

 

 

 

Putting this here for now, part way done - it will get a list of all the block definitions in a drawing and loop through each in turn. In each block looping through each entity to see what it is. For now this just puts into the command line each type in each block.

 

Command BlItemList

 

Might be needing some more help shortly though, for example "do any blocks on page contain circle and text?" - does that mean -any- circle and -any- text or is it to be specified? This is the next step below, look at each item in a block and see if it matches a block to be replaced

 

 

 

;;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/get-entities-inside-a-block/td-p/2644829
(defun getblkitems ( EntName / nfo item items)
  (setq nfo (entget EntName))
  (progn
    (vlax-for item (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object) ) )
                   (cdr (assoc 2 nfo)) )
                   (setq items (cons (vlax-vla-object->ename item) items))
    ) ;end vlax
  ) ; end progn
)
(defun GetBList (/ data name lst) ; returns block entity names
  (while (setq data (tblnext "block" (null data)))
    (setq name (cdr (assoc 2 data)))
    (if (wcmatch name "*|*,`*X*,`*U*,`*D*") nil (setq lst (cons (tblobjname "block" name) lst)) )
  )
)
(defun c:BlItemsList ( / BlkItems n x enttypelist EntgetXType)
  (foreach n (GetBList) ; n: each bock entity
    (setq EntTypeList (list 0 0 0 0 0)) ;; Line (all types) Circle Text Hatch Arcs
    (setq BlkItems (getblkitems n))
    (princ "\n:--")(princ n)(princ ": ")(princ BlkItems)
    (foreach x BlkItems
      (setq EntgetXType (cdr (assoc 0 (entget x))))
      (if (wcmatch EntgetXType "LINE")   (setq EntTypeList (mapcar '+ (list 1 0 0 0 0) EntTypeList)))
      (if (wcmatch EntgetXType "CIRCLE") (setq EntTypeList (mapcar '+ (list 0 1 0 0 0) EntTypeList)))
      (if (wcmatch EntgetXType "*TEXT")  (setq EntTypeList (mapcar '+ (list 0 0 1 0 0) EntTypeList)))
      (if (wcmatch EntgetXType "HATCH")  (setq EntTypeList (mapcar '+ (list 0 0 0 1 0) EntTypeList)))
      (if (wcmatch EntgetXType "ARC")    (setq EntTypeList (mapcar '+ (list 0 0 0 0 1) EntTypeList)))
      (setq EntTypeList (subst 1 2 EntTypeList) ) ; make list 1 or 0s
    ) ; end foreach, x
  (princ EntTypeList)
  ) ; end foreach, n
  (princ)
)

 

Edited June 21, 2023 by Steven P

[mhupp]

Dealing with mostly blocks at my old job here is what I have learned.

 

Account for the basepoint of the old blocks vs the new blocks or things will shift.

Use insert with the block name = filepath to new block to update the block definition and all blocks of that type in the drawing.

 (command "_.Insert" (strcat blkname "=" filepath) PT 1 1 0)

 

everything i worked on was at 0 degrees but you might have to take that into account as well.

[Ajmal]

(defun c:BRE (/ *error* blk f ss temp)
 ;; Replace multiple instances of selected blocks (can be different) with selected block
 ;; Size and Rotation will be taken from original block and original will be deleted
 ;; Required subroutines: AT:GetSel
 ;; Alan J. Thompson, 02.09.10

 (vl-load-com)

 (defun *error* (msg)
   (and f *AcadDoc* (vla-endundomark *AcadDoc*))
   (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
     (princ (strcat "\nError: " msg))
   )
 )

 (if
   (and
     (AT:GetSel
       entsel
       "\nSelect replacement block: "
       (lambda (x / e)
         (if
           (and
             (eq "INSERT" (cdr (assoc 0 (setq e (entget (car x))))))
             (/= 4 (logand (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 e))))) 4))
             (/= 4 (logand (cdr (assoc 70 (entget (tblobjname "LAYER" (cdr (assoc 8 e)))))) 4))
           )
            (setq blk (vlax-ename->vla-object (car x)))
         )
       )
     )
     (princ "\nSelect blocks to be repalced: ")
     (setq ss (ssget "_:L" '((0 . "INSERT"))))
   )
    (progn
      (setq f (not (vla-startundomark
                     (cond (*AcadDoc*)
                           ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
                     )
                   )
              )
      )
      (vlax-for x (setq ss (vla-get-activeselectionset *AcadDoc*))
        (setq temp (vla-copy blk))
        (mapcar (function (lambda (p)
                            (vl-catch-all-apply
                              (function vlax-put-property)
                              (list temp p (vlax-get-property x p))
                            )
                          )
                )
                '(Insertionpoint Rotation XEffectiveScaleFactor YEffectiveScaleFactor
                  ZEffectiveScaleFactor
                 )
        )
        (vla-delete x)
      )
      (vla-delete ss)
      (*error* nil)
    )
 )
 (princ)
)

(defun AT:GetSel (meth msg fnc / ent good)
 ;; meth - selection method (entsel, nentsel, nentselp)
 ;; msg - message to display (nil for default)
 ;; fnc - optional function to apply to selected object
 ;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (x) (eq (cdr (assoc 0 (entget (car x)))) "ARC")))
 ;; Alan J. Thompson, 05.25.10
 (setvar 'errno 0)
 (while (not good)
   (setq ent (meth (cond (msg)
                         ("\nSelect object: ")
                   )
             )
   )
   (cond
     ((vl-consp ent)
      (setq good (cond ((or (not fnc) (fnc ent)) ent)
                       ((prompt "\nInvalid object!"))
                 )
      )
     )
     ((eq (type ent) 'STR) (setq good ent))
     ((setq good (eq 52 (getvar 'errno))) nil)
     ((eq 7 (getvar 'errno)) (setq good (prompt "\nMissed, try again.")))
   )
 )
)