Fix All Blocks
Options
- Subscribe to RSS Feed
- Mark Topic as New
- Mark Topic as Read
- Float this Topic for Current User
- Bookmark
- Subscribe
- Mute
- Printer Friendly Page
Fix All Blocks
Not applicable
3,223 Views
3 Replies
Replies (3)
Message 2 of 4
Not applicable
07-04-2019
10:56 PM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
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
Message 3 of 4
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Accepted solution
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)
Message 4 of 4
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Accepted solution
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