Fix All Blocks

Anonymous · ‎07-04-2019

Hello everyone,

I have been putting together a script to automate some changes. It's an amalgamation of a few other scripts I have found here in other parts of the forum. The script takes a re-saved copy of a drawing that is made up in a certain fashion and then re-formats it. I am currently stuck at the fix all blocks stage as I have found a fantastic script by Kent Cooper but cannot get it to loop through every block. I have attached the lisp files originally created by Kent for reference.
If anyone can help that would be great but in the mean time I'll be trying different things. I currently cannot get the right object/variable type to be selected/input but I also think I'm looping wrong.

Anonymous · ‎07-04-2019

I basically put the loop around everything inside the d_FixBlock function but can't figure out what else I've missed doing to make it work.

;-------------------------------------------------------------------------
; *** FIX BLOCKS ***
;-------------------------------------------------------------------------


    ;   Description: Puts all of a blocks sub-entities on layer 0 with color and 
    ;                 linetype set to BYBLOCK. The block, itself, will remain on 
    ;                 its' original layer. 
    ; 		      renamed from fixblock to Blast
    ;******************************************************************************* 
(defun d_FixBlock (/     eBlockSel 	; Block selection 
                   	 lInsertData 	; Entity data 
                   	 sBlockName 	; Block name 
                   	 lBlockData 	; Entity data 
                   	 eSubEntity 	; Sub-entity name 
                   	 lSubData 	; Sub-entity data 
                   	 iCount 	; Counter 
                  ) 

  (setq go T)					; to begin with [make at least one pass]
  (setq blocks (ssget "_X" '((0 . "INSERT")))) 
  (setq block (ssname blocks 0))

  (while
    (and
      go						; will be nil once it makes a pass without finding any non-Xref blocks
      (setq blocks (ssget "_X" '((0 . "INSERT")))) 	; includes Xref's
    )							; and
     (setq go nil)					; "zero out" initially for this pass
     (repeat (sslength blocks)
       (setq block (ssname blocks 0))			; first [remaining] item in selection
       (if (not	(vlax-property-available-p
		  (vlax-ename->vla-object block) 'Path)); i.e. it's not an Xref [ordinary Blocks don't have Path property]
	 (progn
	   (setq GoAgain T)				; it found one, so run the loop again after this pass

  
  ;; Redefine error handler 

  (setq 
    d_#error *error* 
    *error*  d_FB_Error 
  ) ;_ end setq 

  ;; Set up environment 

  (setq #SYSVARS (#SaveSysVars (list "cmdecho")))

  (setvar "cmdecho" 0)
  (command "._undo" "_group")
  

	   

  ;; Get block from user and make sure it's an INSERT type
  (if t ;(setq eBlockSel (ssget  block))
    (progn
;;;      (if (setq lInsertData (entget (car eBlockSel)))
;;;        (if (= (cdr (assoc 0 lInsertData)) "INSERT")
;;;          (setq sBlockName (cdr (assoc 2 lInsertData)))
;;;          (progn
;;;            (alert "Entity selected is not a block!")
;;;            (exit) 
;;;          ) ;_ end progn 
;;;        ) ;_ end if 
;;;        (progn 
;;;          (alert "Invalid Block Selection!") 
;;;          (exit) 
;;;        ) ;_ end progn 
;;;      ) ;_ end if 

      ;; Get block info from the block table 

      (setq sBlockName block)
      (princ "still here?")
      (alert "still here?")
      (setq 
        lBlockData (tblsearch "BLOCK" sBlockName) 
        eSubEntity (cdr (assoc -2 lBlockData)) 
      ) ;_ end setq 

      ;; Make sure block is not an Xref 

      (if (not (assoc 1 lBlockData)) 
        (progn 
          (princ "\nProcessing block: ") 
          (princ sBlockName) 

          (princ "\nUpdating blocks sub-entities. . .") 

          ;; Parse through all of the blocks sub-entities 

          (while eSubEntity 

            (princ " .") 
            (setq lSubData (entget eSubEntity)) 

            ;; Update layer property 

            (if (assoc 8 lSubData) 
              (progn 
                (setq lSubData 
                       (subst 
                         (cons 8 "0") 
                         (assoc 8 lSubData) 
                         lSubData 
                       ) ;_ end subst 
                ) ;_ end setq 
                (entmod lSubData) 
              ) ;_ end progn 
            ) ;_ end if 

            ;; Update the linetype property 

            (if (assoc 6 lSubData) 
              (progn 
                (setq lSubData 
                       (subst 
                         (cons 6 "BYBLOCK") 
                         (assoc 6 lSubData) 
                         lSubData 
                       ) ;_ end subst 
                ) ;_ end setq 
                (entmod lSubData) 
              ) ;_ end progn 
              (entmod (append lSubData (list (cons 6 "BYBLOCK")))) 
            ) ;_ end if 

            ;; Update the color property 

            (if (assoc 62 lSubData) 
              (progn 
                (setq lSubData 
                       (subst 
                         (cons 62 0) 
                         (assoc 62 lSubData) 
                         lSubData 
                       ) ;_ end subst 
                ) ;_ end setq 
                (entmod lSubData) 
              ) ;_ end progn 
              (entmod (append lSubData (list (cons 62 0)))) 
            ) ;_ end if 

            (setq eSubEntity (entnext eSubEntity)) 
    ; get next sub entity 

          ) ; end while 

          ;; Update attributes 

          (idc_FB_UpdAttribs) 

        ) ; end progn 
        (alert "XREF selected. Not updated!") 
      ) ; end if 
    ) ; end progn 
    (alert "Nothing selected.") 
  ) ; end if

	   

;;; Pop error stack and reset environment 

  (idc_RestoreSysVars) 

  (princ "\nDone!") 

  (setq *error* d_#error) 

  (princ)

	   
  	 )						; progn
       )						; if
       (ssdel block blocks)				; remove that entity name from selection, go on to next
     )							; repeat
  )	   
	   
)   ; end defun 

    ;******************************************************************************* 
    ; Function to update block attributes 
    ;******************************************************************************* 
(defun idc_FB_UpdAttribs () 

  ;; Update any attribute definitions 

  (setq iCount 0) 

  (princ "\nUpdating attributes. . .") 
  (if (setq ssInserts (ssget "x" 
                             (list (cons 0 "INSERT") 
                                   (cons 66 1) 
                                   (cons 2 sBlockName) 
                             ) ;_ end list 
                      ) ;_ end ssget 
      ) ;_ end setq 
    (repeat (sslength ssInserts) 

      (setq eBlockName (ssname ssInserts iCount)) 

      (if (setq eSubEntity (entnext eBlockName)) 
        (setq 
          lSubData (entget eSubEntity) 
          eSubType (cdr (assoc 0 lSubData)) 
        ) ;_ end setq 
      ) ;_ end if 

      (while (or (= eSubType "ATTRIB") (= eSubType "SEQEND")) 

        ;; Update layer property 

        (if (assoc 8 lSubData) 
          (progn 
            (setq lSubData 
                   (subst 
                     (cons 8 "0") 
                     (assoc 8 lSubData) 
                     lSubData 
                   ) ;_ end subst 
            ) ;_ end setq 
            (entmod lSubData) 
          ) ;_ end progn 
        ) ;_ end if 

        ;; Update the linetype property 

        (if (assoc 6 lSubData) 
          (progn 
            (setq lSubData 
                   (subst 
                     (cons 6 "BYBLOCK") 
                     (assoc 6 lSubData) 
                     lSubData 
                   ) ;_ end subst 
            ) ;_ end setq 
            (entmod lSubData) 
          ) ;_ end progn 
          (entmod (append lSubData (list (cons 6 "BYBLOCK")))) 
        ) ;_ end if 

        ;; Update the color property 

        (if (assoc 62 lSubData) 
          (progn 
            (setq lSubData 
                   (subst 
                     (cons 62 0) 
                     (assoc 62 lSubData) 
                     lSubData 
                   ) ;_ end subst 
            ) ;_ end setq 
            (entmod lSubData) 
          ) ;_ end progn 
          (entmod (append lSubData (list (cons 62 0)))) 
        ) ;_ end if 

        (if (setq eSubEntity (entnext eSubEntity)) 
          (setq 
            lSubData (entget eSubEntity) 
            eSubType (cdr (assoc 0 lSubData)) 
          ) ;_ end setq 
          (setq eSubType nil) 
        ) ;_ end if 

      ) ; end while 

      (setq iCount (1+ iCount)) 

    ) ; end repeat 

  ) ; end if 
  (command "regen") 
)   ; end defun 

    ;******************************************************************************* 
    ; Function to save a list of system variables 
    ;******************************************************************************* 
(defun #SaveSysVars (lVarList / sSystemVar) 
  (mapcar 
    '(lambda (sSystemVar) 
       (setq lSystemVars 
              (append lSystemVars 
                      (list (list sSystemVar (getvar sSystemVar))) 
              ) ;_ end append 
       ) ;_ end setq 
     ) ;_ end lambda 
    lVarList 
  ) ;_ end mapcar 

  lSystemVars 

) ;_ end defun 
    ;******************************************************************************* 
    ; Function to restore a list of system variables 
    ;******************************************************************************* 
(defun idc_RestoreSysVars () 
  (mapcar 
    '(lambda (sSystemVar) 
       (setvar (car sSystemVar) (cadr sSystemVar)) 
     ) ;_ end lambda 
    #SYSVARS 
  ) ;_ end mapcar 
) ;_ end defun 
    ;******************************************************************************* 
    ; Error Handler 
    ;******************************************************************************* 
(defun d_FB_Error (msg) 

  (princ "\nError occurred in the Fix Block routine...") 
  (princ "\nError: ") 
  (princ msg) 

  (setq *error* d_#error) 
  (if *error* 
    (*error* msg) 
  ) ;_ end if 

  (command) 

  (if (/= msg "quit / exit abort") 
    (progn 
      (command "._undo" "_end") 
      (command "._u") 
    ) ;_ end progn 
  ) ;_ end if 

  (idc_RestoreSysVars) 

  (princ) 

) ;_ end defun 
    ;******************************************************************************* 

(defun C:Blast () (d_FixBlock)) 

;;  = change all Block Entities of definitions of a selected block and all
;;    nested block definitions within it to the Layer of the Top-level Block
;;  Kent Cooper, 18 November 2014

(vl-load-com)
(defun BELTB (/ *error* doc nametolist blkss inc blk lay blknames ent edata)

  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    ); if
    (vla-endundomark doc)
    (princ)
  ); defun - *error*

  (defun nametolist (blk / blkobj blkname); get Block name and put it into list of names
    (if (= (logand (cdr (assoc 70 (entget blk))) 4) 0) ; not an Xref
      (progn
        (setq
          blkobj (vlax-ename->vla-object blk)
          blkname
            (vlax-get-property blkobj
              (if (vlax-property-available-p blkobj 'EffectiveName) 'EffectiveName 'Name)
                ; to work with older versions that don't have dynamic Blocks
            ); ...get-property & blkname
        ); setq
        (if
          (not (member blkname blknames)); name not already in list
          (setq blknames (append blknames (list blkname))); then -- add to end of list
        ); if
      ); progn
    ); if
  ); defun -- nametolist

  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark doc); = Undo Begin

  (if (setq blkss (ssget "_+.:S" '((0 . "INSERT")))); User selection of a Block/Minsert/Xref
    (progn ; then
      (setq
        blk (ssname blkss 0); top-level Block insertion
        lay (cdr (assoc 8 (entget blk))); Layer it's inserted on
      ); setq
      (nametolist blk); put it in blknames list
      (while (setq blk (car blknames)); as long as there's another Block name in list
        ;; done this way instead of via (repeat) or (foreach), so it can add nested Blocks' names to list
        (setq ent (tblobjname "block" blk)); Block definition as entity
        (while (setq ent (entnext ent)); then -- proceed through sub-entities in definition
          (setq edata (entget ent)); entity data list
          (if (member '(0 . "INSERT") edata) (nametolist ent)); if nested Block, add name to end of list
          (entmod (subst (cons 8 lay) (assoc 8 edata) edata)); change to top-level Block's Layer
        ); while -- sub-entities
        (setq blknames (cdr blknames)); take first one off
      ); while
      (command "_.regen")
    ); progn
    (prompt "\nNo Block(s) selected.")
  ); if [user selection]

  (vla-endundomark doc); = Undo End
  (princ)
); defun

marko_ribar · ‎07-04-2019

To acquire all blocks, I suggest that you iterate through block collection definitions and change properties of sub entities of definitions... If there are attributes - ATTDEF-s, remember you use ATTSYNC command at the end... To get blocks collection : (setq blkcoll (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))... Then iterating goes with : (vlax-for blk blkcoll ... )... When iterating through collection, you should check for xrefs : (= (vla-get-isxref blk) :vlax-false); model/paper space block : (not (wcmatch (strcase (vla-get-name blk)) "*SPACE*"))... And to get ATTDEF-s vla-objects, you should call : (setq attdefs-vla-objs (append (vlax-invoke blk 'getattributes) (vlax-invoke blk 'getconstantattributes)))... When changed properties for attributes : (vlax-for attdef attdefs-vla-objs ... ), you should iterate through block definition itself : (vlax-for obj blk ... )... Now here you don't have to look for nested blocks as you are inspecting all block definitions from main collection that contains both normal blocks, dynamic blocks, nested blocks, space blocks and xrefs structured in non-nested list manner when iterating...

[EDIT : I've created one snippet chk routine for you to inspect what I explained - I've commented out what was my mistake in first explanation...]

(defun c:blkchk nil
  (vl-load-com)
  (vlax-for blk (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
    (cond
      ( (and (= (vla-get-isxref blk) :vlax-false) (wcmatch (strcase (vla-get-name blk)) "*SPACE*"))
        (princ (strcat "\n" (vla-get-name blk)))
      )
      ( (and (= (vla-get-isxref blk) :vlax-false) (not (wcmatch (strcase (vla-get-name blk)) "*SPACE*")))
        ;;;(setq attdefs (append (vlax-invoke blk 'getattributes) (vlax-invoke blk 'getconstantattributes)))
        ;;;(vlax-for attdef attdefs
          ;;;(princ (strcat "\n" (vla-get-objectname attdef)))
        ;;;)
        (vlax-for obj blk
          (princ (strcat "\n" (vla-get-objectname obj)))
        )
      )
    )
  )
  (princ)
)

Marko Ribar, d.i.a. (graduated engineer of architecture)

Anonymous · ‎07-09-2019

thanks, I had a bit of a crack at setting the properties of the sub entities but I just couldn't quite figure it out before another solution was offered. Since it's solved I'll mark as solved and supply a link to the other post as well. Again thanks for you help as well, I do understand it a bit better now

link : https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/fix-all-blocks/m-p/8897111/highlight...

Community

Fix All Blocks

Fix All Blocks

Fix All Blocks