hi experts,
i need a lisp which can do the following
Say i have multiple Similar Geometrical Blocks but its block names are Different,
I would like to convert them to same block name
BricsCAD has this option by default under the commend Overkill -Combine duplicate block definitions
I have attached a sample picture below
Kindly Help me out experts
regards,
Paul
@sadishpaulTry with express tool BLOCKREPLACE (Express tools -> Blocks-> Replace block with another block). After you've replaced all blacks purge drawing.
Miljenko Hatlak
Assuming that there are two similar blocks Block1 and Block2 and you want to replace all instances of Block1 with Block2 retaining its scale and rotation, and that blocks have no attributes this may work. Just fill the list of block names to be changed. Test on file copy.
(defun c:replace_duplicate_block_definitions ( / block_replace_names ss i ent)
(defun *error* (msg)
(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))
(progn
(princ (strcat "\nOops an Error : ( " msg " ) occurred."))
)
)
(if (and adoc) (vla-endundomark adoc))
(setvar 'cmdecho 1)
(princ)
)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(vla-endundomark adoc)
(vla-startundomark adoc)
;Edit this list of block names to be changed
;Add as many (existing_block_name wanted_block_name) Names are case sensitive
(setq block_replace_names
'(
("Block2" "Block1")
)
)
(setvar 'cmdecho 0)
(foreach e block_replace_names
(setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 (car e)))))
(setq i -1)
(cond
((and ss)
(while (< (setq i (1+ i)) (sslength ss))
(setq ent (entget (ssname ss i)))
(setq ent (subst (cons 2 (cadr e)) (assoc 2 ent) ent))
(entmod ent)
)
)
)
)
(setvar 'cmdecho 1)
(vla-endundomark adoc)
(princ)
)You can use function getblocks to collect in a list names of all blocks in file
(defun c:getblocks (/ adoc name lst)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(vlax-for blk (vla-get-blocks adoc)
;; Exclude model and paper spaces, xref and anonymus blocks
(if (and (equal (vla-get-IsLayout blk) :vlax-false)
(equal (vla-get-IsXref blk) :vlax-false)
(/= (substr (vla-get-Name blk) 1 1) "*"))
(setq lst (cons (vla-get-Name blk) lst))
)
)
lst
)
Miljenko Hatlak
Are all the Blocks in the "before" category shown at 0° rotation? So that in the "after" you want what was Block 3 to become an insertion of Block 1 at -45° rotation? And Block 4 to become Block 2 at 45° rotation? If that's the case, most Block-replacing routines [I have one, too] won't do what you want, because they replace Block insertions with a different Block name but retaining their rotations [and insertion points, and scale factors, and Layers].
I dont know is there any1 who is fallowing this topic but i found a lisp routine a little close to this issue. The lisp changes desired blocks as source block . but block directions and insertation points are also changing. I need to keep blocks directions as it was.
(defun c:frto(/ ACTDOC COPOBJ ERRCOUNT EXTLST
EXTSET FROMCEN LAYCOL MAXPT CURLAY
MINPT OBJLAY OKCOUNT OLAYST
SCLAY TOCEN TOOBJ VLAOBJ *ERROR* ASK)
(vl-load-com)
(defun *ERROR*(msg)
(if olaySt (vla-put-Lock objLay olaySt)); end if
(vla-EndUndoMark actDoc)(princ)); end of *ERROR*
(defun GetBoundingCenter(vlaObj / blPt trPt cnPt)
(vla-GetBoundingBox vlaObj 'minPt 'maxPt)
(setq blPt(vlax-safearray->list minPt)
trPt(vlax-safearray->list maxPt)
cnPt(vlax-3D-point
(list
(+(car blPt)(/(-(car trPt)(car blPt))2))
(+(cadr blPt)(/(-(cadr trPt)(cadr blPt))2))
(+(caddr blPt)(/(-(caddr trPt)(caddr blPt))2)) ;_<<< Çàìåíèëè
)))); end of GetBoundingCenter
(setq extSet(ssget "_I"))
(while (not (setq toObj(entsel "\n+++ Select source object -> ")))
(princ "\nSource objects isn't selected!"))
(if(not extSet)
(progn
(princ "\n+++ Select destination objects and press Enter <- ")
(setq extSet(ssget "_:L")))); end if
(if(not extSet)(princ "\nDestination objects isn't selected!")); end if
(if (and extSet toObj)
(progn
(initget "Yes No")
(setq ask (getkword "\nRemove destination object [Yes/No] <No>:"))
(setq actDoc (vla-get-ActiveDocument(vlax-get-Acad-object))
layCol (vla-get-Layers actDoc)
extLst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp
(mapcar 'cadr(ssnamex extSet))))
vlaObj (vlax-ename->vla-object(car toObj))
objLay (vla-Item layCol (vla-get-Layer vlaObj))
olaySt (vla-get-Lock objLay)
fromCen (GetBoundingCenter vlaObj)
errCount 0 okCount 0); end setq
(vla-StartUndoMark actDoc)
(foreach obj extLst
(setq toCen (GetBoundingCenter obj)
scLay (vla-Item layCol (vla-get-Layer obj)));end setq
(if(/= :vlax-true(vla-get-Lock scLay))
(progn
(setq curLay(vla-get-Layer obj))
(vla-put-Lock objLay :vlax-false)
(setq copObj(vla-copy vlaObj))
(vla-Move copObj fromCen toCen)
(_kpblc-ent-properties-copy obj copObj)
(vla-put-Layer copObj curLay)
(vla-put-Lock objLay olaySt)
(if (= ask "Yes")(vla-Delete obj))
(setq okCount(1+ okCount))
); end progn
(setq errCount(1+ errCount))
); end if
); end foreach
(princ (strcat "\n" (itoa okCount) " were changed. "
(if(/= 0 errCount)(strcat (itoa errCount) " were on locked layer! ") "")))
(vla-EndUndoMark actDoc)); end progn
(princ "\nSource object isn't selected! ")
); end if
(princ)); end of c:frto
;|=============================================================================
* Ôóíêöèÿ êîïèğîâàíèÿ íàñòğîåê ïğèìèòèâîâ
* Ïàğàìåòğû âûçîâà:
* source ïğèìèòèâ-èñòî÷íèê (vla)
* dest ïğèìèòèâ-ïîëó÷àòåëü (vla)
* Âûïîëíÿåòñÿ êîïèğîâàíèå âñåõ íàñòğîåê (êğîìå òî÷åê, êîîğäèíàò è ò.ï.), åñëè
* ıòî âîçìîæíî. Êîïèğîâàíèå ğàäèóñîâ äóã è îêğóæíîñòåé íå âûïîëíÿåòñÿ.
* Êîíòğîëü è ïğåîáğàçîâàíèå ïàğàìåòğîâ íå âûïîëíÿåòñÿ.
* Ïğèìåğû âûçîâà:
(_kpblc-ent-properties-copy (vlax-ename->vla-object (car (entsel))) (vlax-ename->vla-object (car (entsel))))
* URL http://www.arcada.com.ua/forum/viewtopic.php?t=504&start=15
=============================================================================|;
(defun _kpblc-ent-properties-copy (source dest)
(foreach prop '("Angle" "Layer" "Linetype" "LinetypeScale" "Lineweight"
"Normal" "PlotStyleName" "Thickness" "Color" "Visible"
"Closed" ;|"ConstantWidth" ; íå êîïèğóåòñÿ|; "Elevation" "LinetypeGeneration"
"LinetypeScale" ;|"StartAngle" "EndAngle" ; íå êîïèğóşòñÿ|; "Alignment"
"Backward" "Height" "ObliqueAngle" "Rotation" "ScaleFactor" "StyleName"
"TextGenerationFlag" "TextHeight" "UpsideDown" "AttachmentPoint" "BackgroundFill"
"DrawingDirection" "LineSpacingDistance" "LineSpacingFactor" "LineSpacingStyle" "Width"
"XScaleFactor" "YScaleFactor" "ZScaleFactor" ;| Viewport|; "ArcSmoothness" "CustomScale"
"Direction" "DisplayLocked" "GridOn" "LensLength" "ModelView" "ShadePlot" "SheetView"
"SnapBasePoint" "SnapOn" "SnapRotationAngle" "StandardScale" "Target" "TwistAngle"
"UCSIconAtOrigin" "UCSIconOn" "UCSPerViewport" "ViewportOn")
(if (and (vlax-property-available-p source prop)(vlax-property-available-p dest prop t))
(_kpblc-error-catch
'(lambda ()(vlax-put-property dest prop (vlax-get-property source prop))) nil)))) ;_ end of defun
;|=============================================================================
* Îáîëî÷êà îòëîâà îøèáîê.
* Ïàğàìåòğû âûçîâà:
* protected-function — "çàùèùàåìàÿ" ôóíêöèÿ
* on-error-function — ôóíêöèÿ, âûïîëíÿåìàÿ â ñëó÷àå îøèáêè
* URL http://www.arcada.com.ua/forum/viewtopic.php?t=504&start=15
=============================================================================|;
(defun _kpblc-error-catch
(protected-function on-error-function / catch_error_result)
(setq catch_error_result (vl-catch-all-apply protected-function))
(if (and (vl-catch-all-error-p catch_error_result) on-error-function)
(apply on-error-function
(list (vl-catch-all-error-message catch_error_result)))
catch_error_result)) ;_ end of defun
(princ "\nType FRTO in command line")
@arinc_akkin wrote:
...... I need to keep blocks directions as it was.
Check the code posted under #7. It works the way you want. Alternatively selection of replacement blocks can be made by picking instead of change list. (explained in code).
Miljenko Hatlak
Thanks for the response but both lisps cant be run.
Secondly my block names arn not block1 block2 ... should i change the code according to block name in every new case?
The one i posted is like:
"Select source blocks" than select target blocks"
@arinc_akkin wrote:
Thanks for the response but both lisps cant be run.
Secondly my block names arn not block1 block2 ... should i change the code according to block name in every new case?
Find in code above and change as you need
;Edit this list of block names to be changed
;Add as many (existing_block_name wanted_block_name) Names are case sensitive
(setq block_replace_names
'(
("Block2" "Block1")
)
)Miljenko Hatlak
Maybe someone will find time to make it for you. It's 3-4 lines of code to change.
Miljenko Hatlak
@arinc_akkin wrote:
Thank you for your time.
Try this. Hope this is what you are looking for. All new blocks need to be inserted in drawing.
(defun c:replace_duplicate_block_definitions ( / block_replace_names ss i ent old new pick_block)
(defun *error* (msg)
(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))
(progn
(princ (strcat "\nOops an Error : ( " msg " ) occurred."))
)
)
(if (and adoc) (vla-endundomark adoc))
(princ)
)
(defun pick_block (msg)
(setq e (car(entsel msg)))
(if (and (not e) (= (getvar 'Errno) 7)) (pick_block msg) e)
)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(vla-endundomark adoc)
(vla-startundomark adoc)
(while
(and
(setq old (pick_block "\nSelect old block to be replaced >"))
(setq new (pick_block "\nSelect new block >"))
)
(setq block_replace_names (cons (list old new) block_replace_names))
)
(if block_replace_names
(foreach e block_replace_names
(setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 (cdr (assoc 2 (entget (car e))))))))
(setq i -1)
(cond
((and ss)
(while (< (setq i (1+ i)) (sslength ss))
(setq ent (entget (ssname ss i)))
(setq ent (subst (cons 2 (cdr(assoc 2 (entget(cadr e))))) (assoc 2 ent) ent))
(entmod ent)
(princ "\n")
)
)
)
)
)
(vla-endundomark adoc)
(princ)
)Miljenko Hatlak
