(defun C:ALE_BLK_REINS ( / EntDat EntNam BlkNam PatNam FilNam NewNam EntLst UpdNam NumObj)
(MODESET '("ATTREQ" "EXPERT"))
(setvar "EXPERT" 5) (setvar "ATTREQ" 0)
(if (setq EntLst (nentsel "\nSelect main or nested block to update: "))
(progn
(if (= (length EntLst) 4)
(progn
(if (and (= "DIMENSION" (DXF 0 (entget (car (last EntLst))))) (cdr (last EntLst)))
(setq EntLst (list (car EntLst) (cdr (last EntLst))))
);if
(setq
UpdNam (DXF 2 (entget (last (last EntLst))))
EntNam (car (last EntLst))
)
(if (setq EntDat (entget EntNam)) (setq BlkNam (strcase (DXF 2 EntDat))));if
);progn
(progn
(setq EntNam (car EntLst))
(if (= "ATTRIB" (DXF 0 (entget EntNam)))
(progn
(setq EntNam (ssname (ssget (cadr EntLst)) 0))
(if (setq EntDat (entget EntNam)) (setq BlkNam (strcase (DXF 2 EntDat))));if
);progn
);if
);progn
);if
(if BlkNam
(if
(and
(= (DXF 0 EntDat) "INSERT")
(setq
PatNam (ALE_UtlCfg_GetVal #CfgData "MyApp" "Ins_dir" "")
FilNam
(getfiled
"Block file"
(strcat PatNam BlkNam)
"DWG" 2
)
)
)
(progn
(if (snvalid (setq NewNam (strcase (vl-filename-base FilNam))))
(progn
(or
(= (vl-filename-directory PatNam) (vl-filename-directory FilNam))
(ALE_UtlCfg_SetVal
'#CfgData #CfgFile "MyApp" "Ins_dir" (strcat (vl-filename-directory FilNam) "\\")
)
)
(command "_.INSERT" (strcat BlkNam "=" FilNam)) (command)
(if (and UpdNam (setq UpdNam (ssget "_X" (list (cons 0 "INSERT") (cons 2 UpdNam)))))
(progn
(repeat (setq NumObj (sslength UpdNam))
(setq NumObj (1- NumObj)) (entupd (ssname UpdNam NumObj))
)
(setq UpdNam nil)
)
)
(if (setq UpdNam (ssget "_X" (list (cons 0 "INSERT") (cons 2 BlkNam))))
(progn
(repeat (setq NumObj (sslength UpdNam))
(setq NumObj (1- NumObj)) (entupd (ssname UpdNam NumObj))
)
(setq UpdNam nil)
)
)
(if (equal NewNam BlkNam)
(princ (strcat "\nBlock " BlkNam " updated. "))
(progn
(if (tblsearch "BLOCK" NewNam)
(alert (strcat
"\nBlock " BlkNam " updated"
"\nbut not renamed in " NewNam
"\n\nBlock " NewNam " already exist in the drawing."
"\n\nAttention, now the two blocks are equal but with different name!"
) )
(progn
(command "_RENAME" "_BL" BlkNam NewNam)
(princ (strcat "\nBlock " BlkNam " updated and renamed in " NewNam " "))
)
)
)
)
(and (getcname "_ATTSYNC") (= (DXF 66 EntDat) 1) (command "_.ATTSYNC" "_NAME" NewNam)) ; blocco con attributi
)
(alert
(strcat
"Block name " (chr 34) FilNam (chr 34) " not valid:"
"\n\n Inser has been ignored."
) )
);if
);progn
(princ "\nInsufficient information or non valid entity! Try again. ")
);if
(alert "MyApp message:\nA regen needed to modify this Block")
)
);progn
(princ "\nMyApp message:\nNothing selected, function cancelled. ")
);if EntLst
(MODERESET)
(princ)
); defun C:ALE_BLK_REINS
Subroutines not includedI know... it is only an example, there are many sub to post and not needed for the question..
Subroutines not includedWorking version:
(defun C:ALE_BLK_REINS_2 ( / EntDat EntNam BlkNam PatNam FilNam NewNam EntLst UpdNam NumObj)
(defun Dxf (DxfCod EntDat) (cdr (assoc DxfCod EntDat)))
(setvar "EXPERT" 5) (setvar "ATTREQ" 0)
(if (setq EntLst (nentsel "\nSelect main or nested block to update: "))
(progn
(if (= (length EntLst) 4)
(progn
(if (and (= "DIMENSION" (DXF 0 (entget (car (last EntLst))))) (cdr (last EntLst)))
(setq EntLst (list (car EntLst) (cdr (last EntLst))))
);if
(setq
UpdNam (DXF 2 (entget (last (last EntLst))))
EntNam (car (last EntLst))
)
(if (setq EntDat (entget EntNam)) (setq BlkNam (strcase (DXF 2 EntDat))));if
);progn
(progn
(setq EntNam (car EntLst))
(if (= "ATTRIB" (DXF 0 (entget EntNam)))
(progn
(setq EntNam (ssname (ssget (cadr EntLst)) 0))
(if (setq EntDat (entget EntNam)) (setq BlkNam (strcase (DXF 2 EntDat))));if
);progn
);if
);progn
);if
(if BlkNam
(if
(and
(= (DXF 0 EntDat) "INSERT")
(setq
PatNam ""
FilNam
(getfiled
"Block file"
(strcat PatNam BlkNam)
"DWG" 2
)
)
)
(progn
(if (snvalid (setq NewNam (strcase (vl-filename-base FilNam))))
(progn
(command "_.INSERT" (strcat BlkNam "=" FilNam)) (command)
(if (and UpdNam (setq UpdNam (ssget "_X" (list (cons 0 "INSERT") (cons 2 UpdNam)))))
(progn
(repeat (setq NumObj (sslength UpdNam))
(setq NumObj (1- NumObj)) (entupd (ssname UpdNam NumObj))
)
(setq UpdNam nil)
)
)
(if (setq UpdNam (ssget "_X" (list (cons 0 "INSERT") (cons 2 BlkNam))))
(progn
(repeat (setq NumObj (sslength UpdNam))
(setq NumObj (1- NumObj)) (entupd (ssname UpdNam NumObj))
)
(setq UpdNam nil)
)
)
(if (equal NewNam BlkNam)
(princ (strcat "\nBlock " BlkNam " updated. "))
(progn
(if (tblsearch "BLOCK" NewNam)
(alert (strcat
"\nBlock " BlkNam " updated"
"\nbut not renamed in " NewNam
"\n\nBlock " NewNam " already exist in the drawing."
"\n\nAttention, now the two blocks are equal but with different name!"
) )
(progn
(command "_RENAME" "_BL" BlkNam NewNam)
(princ (strcat "\nBlock " BlkNam " updated and renamed in " NewNam " "))
)
)
)
)
(and (getcname "_ATTSYNC") (= (DXF 66 EntDat) 1) (command "_.ATTSYNC" "_NAME" NewNam)) ; blocco con attributi
)
(alert
(strcat
"Block name " (chr 34) FilNam (chr 34) " not valid:"
"\n\n Inser has been ignored."
) )
);if
);progn
(princ "\nInsufficient information or non valid entity! Try again. ")
);if
(alert "MyApp message:\nA regen needed to modify this Block")
)
);progn
(princ "\nMyApp message:\nNothing selected, function cancelled. ")
);if EntLst
(setvar "EXPERT" 0) (setvar "ATTREQ" 1)
(princ)
)
(defun mpx-copy-block-to-ms-in-new-doc ( source-dwg block-name / :item :objects :copy-objects :create-odbx-doc :release-docs :main )
;; Michael Puckett, 2018-03-26.
;;
;; Written quick and dirty for my friend Marc'Antonio Alessi.
;;
;; (mpx-copy-block-to-ms-in-new-doc
;; "c:\\an-existing-drawing.dwg"
;; "some-block-name-in-existing-drawing"
;; )
;;
;; If successful returns the name of a new drawing that
;; hosts the desired block's contents in modelspace so that
;; the drawing may be used in an insert=drawing construct
;; to re-define a block.
(defun :item ( owner key / item )
(vl-catch-all-apply 'eval
'((setq item (vla-item owner key)))
)
item
)
(defun :objects ( owner / lst )
(vl-catch-all-apply 'eval
'((vlax-for x owner (setq lst (cons x lst))))
)
(reverse lst)
)
(defun :copy-objects ( source-doc objects new-owner / result )
(vl-catch-all-apply 'eval
'( (progn
(vlax-invoke-method
source-doc
'CopyObjects
(vlax-safearray-fill
(vlax-make-safearray vlax-vbObject (cons 0 (1- (length objects))))
objects
)
new-owner
)
(setq result t)
)
)
)
result
)
(defun :create-odbx-doc ( )
( (lambda ( pid vid )
(vla-getinterfaceobject
(vlax-get-acad-object)
(if (< 15 vid)
(strcat pid (strcat "." (itoa vid)))
pid
)
)
)
"ObjectDBX.AxDbDocument"
(atoi (getvar "acadver"))
)
)
(defun :release-docs ( docs )
(foreach x (mapcar 'list docs)
(vl-catch-all-apply 'vla-close x)
(vl-catch-all-apply 'vlax-release-object x)
)
)
(defun :main ( source-dwg block-name / temp-dwg source-doc block objects new-doc new-name result )
(and
(setq temp-dwg (vl-filename-mktemp "temp.dwg"))
(vl-file-copy source-dwg temp-dwg)
(findfile temp-dwg)
(setq source-doc (:create-odbx-doc))
(progn
(vl-catch-all-apply 'vla-open (list source-doc temp-dwg))
(setq block (:item (vla-get-blocks source-doc) block-name))
)
(setq objects (:objects block))
(setq new-doc (:create-odbx-doc))
(:copy-objects source-doc objects (vla-get-modelspace new-doc))
(setq new-name (vl-filename-mktemp "temp.dwg"))
(progn
(vl-catch-all-apply 'vla-saveas (list new-doc new-name))
(if (findfile new-name)
(setq result new-name)
)
)
)
(:release-docs (list source-doc new-doc))
(vl-catch-all-apply 'vl-file-delete (list temp-path))
result
)
(:main source-dwg block-name)
)
Bashed this out over lunch. Should be 90% of what you need Marc.;; Written quick and dirty for my friend Marc'Antonio Alessi.
... Cheers.
Bashed this out over lunch. Should be 90% of what you need Marc.Michael,
<clip>
;(ALE_Block_UpdByBlkInFile (cons "MyBlockAbc" "Z:\\Temp\\foo.dwg") (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-Acad-Object))) nil)
;(ALE_Block_UpdByBlkInFile (cons "SubBlock1" "Z:\\Temp\\foo.dwg") (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-Acad-Object))) nil)
;
; Original New Block Def
; BlkInf = List '("BlockName" . "c:\\Temp\\SourceFile.dwg")
; BksCol = (vla-get-blocks DbxDoc)
; BitVal = not used
;
; (ALE_Block_UpdByBlkInFile (cons BlkNam FilNam) (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-Acad-Object))) nil)
;
(defun ALE_Block_UpdByBlkInFile (BlkInf BksCol BitVal / BksSrc DbxDoc FilNam BksSrc BlkSrc BlkObj ObjLst BlkNam WhoStr WhoInf ErrFlg)
(defun ALE_Utl_GetItem (VlaCol KeyNam / VlaObj)
(vl-catch-all-apply
'(lambda ( )
(setq VlaObj (vla-item VlaCol KeyNam))
)
)
VlaObj
)
(setq
BlkNam (car BlkInf) FilNam (cdr BlkInf)
DbxDoc (vla-GetInterfaceObject *AcadApp* (strcat "ObjectDBX.AxDbDocument." (substr (getvar "ACADVER") 1 2)))
ErrFlg (vl-catch-all-error-p (vl-catch-all-apply 'vla-Open (list DbxDoc FilNam)))
)
(cond
( ErrFlg (alert "Unable to open drawing.") ) ; (ALE_Files_WhoHasPrompt FilNam)
( (and
(setq BlkObj (ALE_Utl_GetItem BksCol BlkNam)) ;destination block del file aperto
(setq BksSrc (vla-get-Blocks DbxDoc)) ;source blocks coll.
(setq BlkSrc (ALE_Utl_GetItem BksSrc BlkNam)) ;source block
)
(vlax-for ObjFor BlkObj (vla-delete ObjFor)) ;delete existing items on destination block
(vlax-for ObjFor BlkSrc (setq ObjLst (cons ObjFor ObjLst)))
(vlax-invoke DbxDoc 'copyobjects ObjLst BlkObj);copy objects from source drawing to destination block
(vlax-release-object BlkObj)(vlax-release-object BksSrc)
)
( T
(setq ErrFlg T)
(alert (strcat "\nBlock: " BlkNam " not found on selected Dwg!" ))
)
)
(and DbxDoc (or (vlax-object-released-p DbxDoc) (vlax-release-object DbxDoc)))
(not ErrFlg)
)
The results are in the attached files, now I see if I can also update the nested blocks in a single pass...
; Function: ALE_Block_UpdByBlkInFile
;
; Version 1.02 - 2018/04/04
;
; BlkNam = "BlockName" > Original > String
; FilNam = "C:\\Temp\\SourceFile.dwg" > New Block Def > String
; BksCol = (vla-get-blocks Doc)
; BitVal = not used
;
(or *AcadApp* (setq *AcadApp* (vlax-get-Acad-Object) )) ; edit 20210321
(or *AcAcDwg* (setq *AcAcDwg* (vla-get-ActiveDocument *AcadApp*))) ; edit 20210321
;
; (ALE_Block_UpdByBlkInFile BlkNam FilNam (vla-get-Blocks *AcAcDwg*) nil) ; edit 20210321
;
(defun ALE_Block_UpdByBlkInFile (BlkNam FilNam BksCol BitVal / DbxDoc BksSrc BlkSrc BlkObj ObjLst ForNam WhoStr WhoInf ErrFlg BlkLst)
(setq
DbxDoc (vla-GetInterfaceObject *AcadApp* (strcat "ObjectDBX.AxDbDocument." (substr (getvar "ACADVER") 1 2)))
ErrFlg (vl-catch-all-error-p (vl-catch-all-apply 'vla-Open (list DbxDoc FilNam)))
)
(cond
( ErrFlg (alert "Unable to open drawing.") )
( (and
(setq BlkObj (ALE_Utl_GetItem BksCol BlkNam)) ;destination block
(setq BksSrc (vla-get-Blocks DbxDoc)) ;source blocks coll.
(setq BlkSrc (ALE_Utl_GetItem BksSrc BlkNam)) ;source block
)
(vlax-for ObjFor BlkObj (vla-delete ObjFor)) ;delete existing items on destination block
(vlax-for ObjFor BlkSrc
(and
(= "AcDbBlockReference" (vla-get-ObjectName ObjFor))
(not (vl-position (setq ForNam (vla-get-EffectiveName ObjFor)) BlkLst))
(setq BlkLst (cons ForNam BlkLst))
(setq BlkLst (ALE_Block_UpdByNestedBlkInFile BlkLst ForNam BksCol BksSrc DbxDoc BitVal))
)
(setq ObjLst (cons ObjFor ObjLst))
)
(vlax-invoke DbxDoc 'copyobjects ObjLst BlkObj) ;copy objects from source drawing to destination block
(vlax-release-object BlkObj)(vlax-release-object BksSrc)
(vla-regen *AcAcDwg* acActiveViewport)
(princ (strcat "\nnBlock " BlkNam " Updated. " ))
)
( T
(setq ErrFlg T)
(alert (strcat "\nBlock: " BlkNam " not found on selected Dwg!" ))
)
)
(and DbxDoc (or (vlax-object-released-p DbxDoc) (vlax-release-object DbxDoc)))
(not ErrFlg)
)
;
; Recursive
;
(defun ALE_Block_UpdByNestedBlkInFile (BlkLst BlkNam BksCol BksSrc DbxDoc BitVal / BlkObj ObjLst ForNam)
(if (setq BlkObj (ALE_Utl_GetItem BksCol BlkNam))
(progn
(vlax-for ObjFor BlkObj (vla-delete ObjFor))
(vlax-for ObjFor (ALE_Utl_GetItem BksSrc BlkNam)
(and
(= "AcDbBlockReference" (vla-get-ObjectName ObjFor))
(not (vl-position (setq ForNam (vla-get-EffectiveName ObjFor)) BlkLst))
(setq BlkLst (cons ForNam BlkLst))
(setq BlkLst (ALE_Block_UpdByNestedBlkInFile BlkLst ForNam BksCol BksSrc DbxDoc BitVal))
)
(setq ObjLst (cons ObjFor ObjLst))
)
(vlax-invoke DbxDoc 'copyobjects ObjLst BlkObj)
(vlax-release-object BlkObj)
(princ (strcat "\nnBlock " BlkNam " Updated. " ))
)
)
BlkLst
)
(defun ALE_Utl_GetItem (VlaCol KeyNam / VlaObj)
(vl-catch-all-apply
'(lambda ( )
(setq VlaObj (vla-item VlaCol KeyNam))
)
)
VlaObj
)
(defun KGA_Conv_Collection_To_List (coll / ret)
(reverse
(vlax-for a coll
(setq ret (cons a ret))
)
)
)
(defun KGA_Sys_Apply (expr varLst / ret)
(if (not (vl-catch-all-error-p (setq ret (vl-catch-all-apply expr varLst))))
ret
)
)
;;; ======================================================================
;;; Lib function: KGA_Block_Clone
;;; Purpose: Make an accurate clone of a block under a new name.
;;; Can be used to create a named clone from an anonymous
;;; block and vice versa.
;;; Arguments: srcDocObj - Source document object.
;;; trgDocObj - Target document object or nil (= use the srcDocObj).
;;; srcNme - Source block name.
;;; trgNme - Target block name.
;;; overwriteP - Overwrite flag.
;;; Return value: New block definition object.
;;; Remarks: For an anonymous trgNme use "*U" and not just "*".
;;; SrcBlkobj can also be a layout block.
;;; Should not be used while refediting srcNme or trgNme. Use (getvar 'refeditname) to check.
;;; Both the srcDocObj and the trgDocObj can be ODBX documents.
;;; Examples: (setq obj (KGA_Block_Clone (vla-get-activedocument (vlax-get-acad-object)) nil "test" "testClone1" T))
;;; (setq obj (KGA_Block_Clone (vla-get-activedocument (vlax-get-acad-object)) nil "test" "*U" T))
;;; (setq obj (KGA_Block_Clone (vla-get-activedocument (vlax-get-acad-object)) nil "*U3524" "Named" T))
;;; ======================================================================
(defun KGA_Block_Clone (srcDocObj trgDocObj srcNme trgNme overwriteP / srcBlkObj trgBlksObj trgBlkObj)
(if
(and
(or
(/= (strcase srcNme) (strcase trgNme))
(and
srcDocObj
trgDocObj
(not (equal srcDocObj trgDocObj))
)
)
(setq srcBlkObj (KGA_Sys_Apply 'vla-item (list (vla-get-blocks srcDocObj) srcNme)))
(= :vlax-false (vla-get-isxref srcBlkObj))
(setq trgBlksObj (vla-get-blocks (cond (trgDocObj) (srcDocObj))))
(or
(= "*U" (strcase trgNme))
(not (setq trgBlkObj (KGA_Sys_Apply 'vla-item (list trgBlksObj trgNme))))
(and
overwriteP
(= :vlax-false (vla-get-isxref trgBlkObj))
)
)
(setq trgBlkObj ; This will create a new empty block even if trgNme already exists.
(KGA_Sys_Apply 'vlax-invoke (list trgBlksObj 'add (vlax-get srcBlkObj 'origin) trgNme))
)
)
(progn
;; Copy properties:
(mapcar
'(lambda (prop) (vlax-put trgBlkObj prop (vlax-get srcBlkObj prop)))
'(blockscaling comments explodable units) ; Not the path property.
)
;; Copy entities:
(vlax-invoke srcDocObj 'copyobjects (KGA_Conv_Collection_To_List srcBlkObj) trgBlkObj)
;; Copy draworder (required because the CopyObjects method fails to clone this):
(KGA_Block_DrawOrderClone srcBlkObj trgBlkObj)
trgBlkObj
)
)
)
; Return value: List of objects. Last object is the top of the draworder.
(defun KGA_Block_DrawOrder (blkObj / sortArr sortTblObj)
(if
(and
(= :vlax-true (vla-get-hasextensiondictionary blkObj))
; Using (vla-getobject) would still require the use of (KGA_Sys_Apply):
(setq sortTblObj (KGA_Sys_Apply 'vla-item (list (vla-getextensiondictionary blkObj) "ACAD_SORTENTS")))
)
(progn
(vla-getfulldraworder sortTblObj 'sortArr :vlax-false)
(mapcar 'vlax-variant-value (vlax-safearray->list sortArr))
)
)
)
; The function assumes that trgBlkObj has been cloned from srcBlkObj and
; that trgBlkObj does not have a draworder.
; Return value: T or nil.
(defun KGA_Block_DrawOrderClone (srcBlkObj trgBlkObj / srcSortObjLst transLst)
(if (setq srcSortObjLst (KGA_Block_DrawOrder srcBlkObj))
(progn
(setq transLst (mapcar 'cons (KGA_Conv_Collection_To_List srcBlkObj) (KGA_Conv_Collection_To_List trgBlkObj)))
(vlax-invoke
(vla-addobject (vla-getextensiondictionary trgBlkObj) "ACAD_SORTENTS" "AcDbSortentsTable")
'setrelativedraworder
(mapcar '(lambda (obj) (cdr (assoc obj transLst))) srcSortObjLst)
)
T
)
)
)
@Marc'Antonio Alessi:I apologize for the big delay ... what you write is correct. I tried your function but I get an error ... I was wrong about the arguments?
I am not sure if this qualifies as a negative effect but your code will update a block definition for every insert it encounters. If the main block "A" contains 10 inserts "B", the "B" block definition will be updated 10 times. ...
Command: (setq FilNam "Z:\\Temp\\foo.dwg")
"Z:\\Temp\\foo.dwg"
Command: (setq DbxDoc (vla-GetInterfaceObject *AcadApp* (strcat "ObjectDBX.AxDbDocument." (substr (getvar "ACADVER") 1 2))))
#<VLA-OBJECT IAxDbDocument 00000000300ea490>
Command: (setq ErrFlg (vl-catch-all-error-p (vl-catch-all-apply 'vla-Open (list DbxDoc FilNam))))
nil
Command: (setq obj (KGA_Block_Clone DbxDoc (vla-get-activedocument (vlax-get-acad-object)) "MyBlockAbc" "MyBlockAbc" T))
; errore: tipo di argomento errato: variantp #<VLA-OBJECT IAcadLine 000000003019e4f8>
Command: (and DbxDoc (or (vlax-object-released-p DbxDoc) (vlax-release-object DbxDoc)))
T
The arguments you use seem OK. Can you test the same on BricsCAD? I suspect this may be a situation where BC is either not compatible or more tolerant.Yes you are right. In Bricscad I have no errors.
The AutoCAD error is this:
Comando: (setq obj (KGA_Block_Clone DbxDoc (vla-get-activedocument (vlax-get-acad-object)) "MyBlockAbc" "MyBlockAbc" T))
Traccia all'indietro:
[0.80] (VL-BT)
[1.76] (ERRDUMP "tipo di argomento errato: variantp #<VLA-OBJECT IAcadLine 0000000032b5d5a8>")
[2.71] (_call-err-hook #<SUBR @0000000034781318 ERRDUMP> "tipo di argomento errato: variantp #<VLA-OBJECT IAcadLine 0000000032b5d5a8>")
[3.65] (sys-error "tipo di argomento errato: variantp #<VLA-OBJECT IAcadLine 0000000032b5d5a8>")
:ERROR-BREAK.60 nil
[4.57] (variant-value #<VLA-OBJECT IAcadLine 0000000032b5d5a8>)
[5.52] (vlax-variant-value #<VLA-OBJECT IAcadLine 0000000032b5d5a8>)
[6.47] (mapcar #<SUBR @0000000034427778 vlax-variant-value> (#<VLA-OBJECT IAcadLine 0000000032b5d5a8> #<VLA-OBJECT IAcadLine 0000000032b5e568> #<VLA-OBJECT IAcadLine 0000000032b5d1e8> #<VLA-OBJECT IAcadArc 0000000032a9a468> #<VLA-OBJECT IAcadLine 0000000032b5cca8> #<VLA-OBJECT IAcadArc 0000000032a9c3e8> #<VLA-OBJECT IAcadLWPolyline 0000000032b5e868> #<VLA-OBJECT IAcadLine 0000000032b5cd68> #<VLA-OBJECT IAcadLine 0000000032b5c0a8> #<VLA-OBJECT IAcadLine 0000000032b5c2e8> #<VLA-OBJECT IAcadLine 0000000032b5e028> #<VLA-OBJECT IAcadBlockReference 0000000032a9a548> #<VLA-OBJECT IAcadBlockReference 0000000032a9b428> #<VLA-OBJECT IAcadBlockReference 0000000032a993c8> #<VLA-OBJECT IAcadBlockReference 0000000032a9bea8>))
[7.41] (MAPCAR vlax-variant-value (#<VLA-OBJECT IAcadLine 0000000032b5d5a8> #<VLA-OBJECT IAcadLine 0000000032b5e568> #<VLA-OBJECT IAcadLine 0000000032b5d1e8> #<VLA-OBJECT IAcadArc 0000000032a9a468> #<VLA-OBJECT IAcadLine 0000000032b5cca8> #<VLA-OBJECT IAcadArc 0000000032a9c3e8> #<VLA-OBJECT IAcadLWPolyline 0000000032b5e868> #<VLA-OBJECT IAcadLine 0000000032b5cd68> #<VLA-OBJECT IAcadLine 0000000032b5c0a8> #<VLA-OBJECT IAcadLine 0000000032b5c2e8> #<VLA-OBJECT IAcadLine 0000000032b5e028> #<VLA-OBJECT IAcadBlockReference 0000000032a9a548> #<VLA-OBJECT IAcadBlockReference 0000000032a9b428> #<VLA-OBJECT IAcadBlockReference 0000000032a993c8> #<VLA-OBJECT IAcadBlockReference 0000000032a9bea8>))
[8.35] (KGA_BLOCK_DRAWORDER #<VLA-OBJECT IAcadBlock 0000000030097638>)
[9.30] (KGA_BLOCK_DRAWORDERCLONE #<VLA-OBJECT IAcadBlock 0000000030097638> #<VLA-OBJECT IAcadBlock 0000000030096738>)
[10.24] (KGA_BLOCK_CLONE #<VLA-OBJECT IAxDbDocument 00000000328fa960> #<VLA-OBJECT IAcadDocument 0000000032853648> "MyBlockAbc" "MyBlockAbc" T)
[11.15] (#<SUBR @0000000034781638 -rts_top->)
[12.12] (#<SUBR @0000000033968700 veval-str-body> "(setq obj (KGA_Block_Clone DbxDoc (vla-get-activedocument (vlax-get-acad-object)) \"MyBlockAbc\" \"MyBlockAbc\" T))" T #<FILE internal>)
:CALLBACK-ENTRY.6 (:CALLBACK-ENTRY)
:ARQ-SUBR-CALLBACK.3 (nil 0)
Test lines:
(defun errdump (s) (vl-bt) (princ)) (setq *error* errdump)
(setq FilNam "Z:\\Temp\\foo.dwg")
(setq DbxDoc (vla-GetInterfaceObject *AcadApp* (strcat "ObjectDBX.AxDbDocument." (substr (getvar "ACADVER") 1 2))))
(setq ErrFlg (vl-catch-all-error-p (vl-catch-all-apply 'vla-Open (list DbxDoc FilNam))))
(setq obj (KGA_Block_Clone DbxDoc (vla-get-activedocument (vlax-get-acad-object)) "MyBlockAbc" "MyBlockAbc" T))
(and DbxDoc (or (vlax-object-released-p DbxDoc) (vlax-release-object DbxDoc)))
Thanks.
@Marc'Antonio Alessi:Code modified to avoid multiple updates.
I am not sure if this qualifies as a negative effect but your code will update a block definition for every insert it encounters. If the main block "A" contains 10 inserts "B", the "B" block definition will be updated 10 times. To make the code more efficient consider using some sort of doneBlockNameList.
Or work with a blockNameList and an index. For every insert check if the name is already part of the blockNameList, if not append it. And just work through the list while raising the index.
(defun KGA_Conv_Collection_To_List (coll / ret)
(reverse
(vlax-for a coll
(setq ret (cons a ret))
)
)
)
(defun KGA_Sys_Apply (expr varLst / ret)
(if (not (vl-catch-all-error-p (setq ret (vl-catch-all-apply expr varLst))))
ret
)
)
;;; ======================================================================
;;; Lib function: KGA_Block_Update
;;; Purpose: Update a block definition by importing it from a different document.
;;; All referenced 'nested' blocks are also updated.
;;; Arguments: srcDocObj - Source document object.
;;; trgDocObj - Target document object.
;;; nme - Block name.
;;; Return value: Updated main block definition object.
;;; Remarks: The srcDocObj and the trgDocObj must be different objects.
;;; Either or both can be ODBX documents.
;;; Examples:
;;; (setq odbxSrc (KGA_Sys_ImportOpen "C:\\Downloads\\Foo.dwg"))
;;; (setq odbxTrg (KGA_Sys_ImportOpen "C:\\Downloads\\Main.dwg"))
;;; (setq obj (KGA_Block_Update odbxSrc odbxTrg "MyBlockAbc"))
;;; (vla-saveas odbxTrg "C:\\Downloads\\MainNew.dwg")
;;; (KGA_Sys_Release odbxSrc)
;;; (KGA_Sys_Release odbxTrg)
;;; ======================================================================
(defun KGA_Block_Update (srcDocObj trgDocObj nme / N_Clone N_UpdateToDo idx mainDef resLst srcBlksObj toDoLst trgBlksObj trgOldNmeLst)
(defun N_Clone (nme / srcBlkObj srcBlkObjLst trgBlkObj)
(if
(and
(setq srcBlkObj (KGA_Sys_Apply 'vla-item (list srcBlksObj nme)))
(= :vlax-false (vla-get-isxref srcBlkObj))
(or
(not (setq trgBlkObj (KGA_Sys_Apply 'vla-item (list trgBlksObj nme))))
(= :vlax-false (vla-get-isxref trgBlkObj))
)
(setq trgBlkObj ; This will create a new empty block even if nme already exists.
(KGA_Sys_Apply 'vlax-invoke (list trgBlksObj 'add (vlax-get srcBlkObj 'origin) nme))
)
)
(progn
;; Copy other properties:
(mapcar
'(lambda (prop) (vlax-put trgBlkObj prop (vlax-get srcBlkObj prop)))
'(blockscaling comments explodable units) ; Not the path property.
)
;; Copy entities:
(vlax-invoke srcDocObj 'copyobjects (setq srcBlkObjLst (KGA_Conv_Collection_To_List srcBlkObj)) trgBlkObj)
;; Copy draworder (required because the CopyObjects method fails to clone this):
(KGA_Block_DrawOrderClone srcBlkObj trgBlkObj)
(list trgBlkObj srcBlkObjLst)
)
)
)
(defun N_UpdateToDo (srcBlkObjLst / nme)
(foreach obj srcBlkObjLst
(if
(and
(= "AcDbBlockReference" (vla-get-objectname obj))
(setq nme (vla-get-name obj))
(/= "*" (substr nme 1 1))
(vl-position (strcase nme) trgOldNmeLst)
(not (assoc (strcase nme) toDoLst))
)
(setq toDoLst (append toDoLst (list (cons (strcase nme) nme))))
)
)
)
(if
(and
srcDocObj
trgDocObj
(not (equal srcDocObj trgDocObj))
(setq srcBlksObj (vla-get-blocks srcDocObj)) ; Nil if ODBX doc has been released.
(setq trgBlksObj (vla-get-blocks trgDocObj)) ; Idem.
)
(progn
(setq trgOldNmeLst
(mapcar
'(lambda (obj) (strcase (vla-get-name obj)))
(KGA_Conv_Collection_To_List trgBlksObj)
)
)
(setq toDoLst (list (cons (strcase nme) nme)))
(setq idx -1)
(while (< (setq idx (1+ idx)) (length toDoLst))
(if (setq resLst (N_Clone (cdr (nth idx toDoLst))))
(progn
(if (not mainDef) (setq mainDef (car resLst)))
(N_UpdateToDo (cadr resLst))
)
)
)
mainDef
)
)
)
; Return value: List of objects. Last object is the top of the draworder.
(defun KGA_Block_DrawOrder (blkObj / sort sortTblObj)
(if
(and
(= :vlax-true (vla-get-hasextensiondictionary blkObj))
; Using (vla-getobject) would still require the use of (KGA_Sys_Apply):
(setq sortTblObj (KGA_Sys_Apply 'vla-item (list (vla-getextensiondictionary blkObj) "ACAD_SORTENTS")))
)
(progn
(vla-getfulldraworder sortTblObj 'sort :vlax-false)
(setq sort (vlax-safearray->list sort))
(if (= 'variant (type (car sort)))
(mapcar 'vlax-variant-value sort) ; BricsCAD.
sort ; AutoCAD
)
)
)
)
; The function assumes that trgBlkObj has been cloned from srcBlkObj and
; that trgBlkObj does not have a draworder.
; Return value: T or nil.
(defun KGA_Block_DrawOrderClone (srcBlkObj trgBlkObj / srcSortObjLst transLst)
(if (setq srcSortObjLst (KGA_Block_DrawOrder srcBlkObj))
(progn
(setq transLst (mapcar 'cons (KGA_Conv_Collection_To_List srcBlkObj) (KGA_Conv_Collection_To_List trgBlkObj)))
(vlax-invoke
(vla-addobject (vla-getextensiondictionary trgBlkObj) "ACAD_SORTENTS" "AcDbSortentsTable")
'setrelativedraworder
(mapcar '(lambda (obj) (cdr (assoc obj transLst))) srcSortObjLst)
)
T
)
)
)
Here is my attempt (with a fix for the KGA_Block_DrawOrder function):KGA_Sys_ImportOpen KGA_Sys_Release are missing so I tested with:
(setq FilNam "Z:\\Temp\\foo.dwg")
(setq odbxSrc (vla-GetInterfaceObject *AcadApp* (strcat "ObjectDBX.AxDbDocument." (substr (getvar "ACADVER") 1 2))))
(setq ErrFlg (vl-catch-all-error-p (vl-catch-all-apply 'vla-Open (list odbxSrc FilNam))))
(setq odbxTrg (vla-get-activedocument (vlax-get-acad-object)))
(setq obj (KGA_Block_Update odbxSrc odbxTrg "MyBlockAbc"))
(and odbxSrc (or (vlax-object-released-p odbxSrc) (vlax-release-object odbxSrc)))
Very strange in BricsCAD all seems ok,Code: [Select]< ... >
(setq trgBlkObj ; This will create a new empty block even if nme already exists.
(KGA_Sys_Apply 'vlax-invoke (list trgBlksObj 'add (vlax-get srcBlkObj 'origin) nme))
)
< ... >
FYI, in AutoCAD, a call to Add method of a Collection will return the existing item if present, it not create a new item to replace the existing.Thanks Lee!
(defun KGA_Conv_Collection_To_List (coll / ret)
(reverse
(vlax-for a coll
(setq ret (cons a ret))
)
)
)
(defun KGA_Sys_Apply (expr varLst / ret)
(if (not (vl-catch-all-error-p (setq ret (vl-catch-all-apply expr varLst))))
ret
)
)
;;; ======================================================================
;;; Lib function: KGA_Block_Update
;;; Purpose: Update a block definition by importing it from a different document.
;;; All referenced 'nested' blocks are also updated.
;;; Arguments: srcDocObj - Source document object.
;;; trgDocObj - Target document object.
;;; nme - Block name.
;;; Return value: Updated main block definition object.
;;; Remarks: The srcDocObj and the trgDocObj must be different objects.
;;; Either or both can be ODBX documents.
;;; Examples:
;;; (setq odbxSrc (KGA_Sys_ImportOpen "C:\\Downloads\\Foo.dwg"))
;;; (setq odbxTrg (KGA_Sys_ImportOpen "C:\\Downloads\\Main.dwg"))
;;; (setq obj (KGA_Block_Update odbxSrc odbxTrg "MyBlockAbc"))
;;; (vla-saveas odbxTrg "C:\\Downloads\\MainNew.dwg")
;;; (KGA_Sys_Release odbxSrc)
;;; (KGA_Sys_Release odbxTrg)
;;; ======================================================================
(defun KGA_Block_Update (srcDocObj trgDocObj nme / N_Clone N_UpdateToDo idx mainDef resLst srcBlksObj toDoLst trgBlksObj trgOldNmeLst)
(defun N_Clone (nme / srcBlkObj srcBlkObjLst trgBlkObj)
(if
(and
(setq srcBlkObj (KGA_Sys_Apply 'vla-item (list srcBlksObj nme)))
(= :vlax-false (vla-get-isxref srcBlkObj))
(setq trgBlkObj
(cond
((KGA_Sys_Apply 'vla-item (list trgBlksObj nme)))
((KGA_Sys_Apply 'vlax-invoke (list trgBlksObj 'add '(0.0 0.0 0.0) nme)))
)
)
(= :vlax-false (vla-get-isxref trgBlkObj))
)
(progn
;; Delete entities:
(mapcar 'vla-delete (KGA_Conv_Collection_To_List trgBlkObj))
;; Copy entities:
(vlax-invoke srcDocObj 'copyobjects (setq srcBlkObjLst (KGA_Conv_Collection_To_List srcBlkObj)) trgBlkObj)
;; Copy properties:
(mapcar
'(lambda (prop) (vlax-put trgBlkObj prop (vlax-get srcBlkObj prop)))
'(blockscaling comments explodable origin units) ; Not the path property.
)
;; Copy draworder (required because the CopyObjects method fails to clone this):
(KGA_Block_DrawOrderClone srcBlkObj trgBlkObj)
(list trgBlkObj srcBlkObjLst)
)
)
)
(defun N_UpdateToDo (srcBlkObjLst / nme)
(foreach obj srcBlkObjLst
(if
(and
(= "AcDbBlockReference" (vla-get-objectname obj))
(setq nme (vla-get-name obj))
(/= "*" (substr nme 1 1))
(vl-position (strcase nme) trgOldNmeLst)
(not (assoc (strcase nme) toDoLst))
)
(setq toDoLst (append toDoLst (list (cons (strcase nme) nme))))
)
)
)
(if
(and
srcDocObj
trgDocObj
(not (equal srcDocObj trgDocObj))
(setq srcBlksObj (vla-get-blocks srcDocObj)) ; Nil if ODBX doc has been released.
(setq trgBlksObj (vla-get-blocks trgDocObj)) ; Idem.
)
(progn
(setq trgOldNmeLst
(mapcar
'(lambda (obj) (strcase (vla-get-name obj)))
(KGA_Conv_Collection_To_List trgBlksObj)
)
)
(setq toDoLst (list (cons (strcase nme) nme)))
(setq idx -1)
(while (< (setq idx (1+ idx)) (length toDoLst))
(if (setq resLst (N_Clone (cdr (nth idx toDoLst))))
(progn
(if (not mainDef) (setq mainDef (car resLst)))
(N_UpdateToDo (cadr resLst))
)
)
)
mainDef
)
)
)
; Return value: List of objects. Last object is the top of the draworder.
(defun KGA_Block_DrawOrder (blkObj / sort sortTblObj)
(if
(and
(= :vlax-true (vla-get-hasextensiondictionary blkObj))
; Using (vla-getobject) would still require the use of (KGA_Sys_Apply):
(setq sortTblObj (KGA_Sys_Apply 'vla-item (list (vla-getextensiondictionary blkObj) "ACAD_SORTENTS")))
)
(progn
(vla-getfulldraworder sortTblObj 'sort :vlax-false)
(setq sort (vlax-safearray->list sort))
(if (= 'variant (type (car sort)))
(mapcar 'vlax-variant-value sort) ; BricsCAD.
sort ; AutoCAD
)
)
)
)
; The function assumes that trgBlkObj has been cloned from srcBlkObj and
; that trgBlkObj does not have a draworder.
; Return value: T or nil.
(defun KGA_Block_DrawOrderClone (srcBlkObj trgBlkObj / srcSortObjLst transLst)
(if (setq srcSortObjLst (KGA_Block_DrawOrder srcBlkObj))
(progn
(setq transLst (mapcar 'cons (KGA_Conv_Collection_To_List srcBlkObj) (KGA_Conv_Collection_To_List trgBlkObj)))
(vlax-invoke
(vla-addobject (vla-getextensiondictionary trgBlkObj) "ACAD_SORTENTS" "AcDbSortentsTable")
'setrelativedraworder
(mapcar '(lambda (obj) (cdr (assoc obj transLst))) srcSortObjLst)
)
T
)
)
)
Everything seems ok even in AutoCAD. :) :) :)FYI, in AutoCAD, a call to Add method of a Collection will return the existing item if present, it not create a new item to replace the existing.Thanks Lee!
Revised code (fingers crossed...):
...
FYI, in AutoCAD, a call to Add method of a Collection will return the existing item if present, it not create a new item to replace the existing.Thanks Lee!
Everything seems ok even in AutoCAD. :) :) :)Good to hear that. :-D
From the number of visits I think your work has been much appreciated, thanks again. :-)Everything seems ok even in AutoCAD. :) :) :)Good to hear that. :-D
Just a heads up, you are using global variables not defined in the code which may cause people confusion.>>> you are using global variables not defined in the code which may cause people confusion Where?
*AcadApp* = (vlax-get-acad-object)
*AcAcDwg* = (vla-get-ActiveDocument (vlax-get-acad-object))
Otherwise, my initial tests looked very promising. Going to use it to create a DCL for some mass block redefining. ;D
Thanks everyone who contributed!
Post #15, "Function: ALE_Block_UpdByBlkInFile, Version 1.02 - 2018/04/04..." used the variables I mentioned above.Yes :yes: you are correct, code updated:
; Block name Layer name Layout name
; BksInf (("TITLEBLOCK" "LAYERX" "MODEL" #<VLA-OBJECT IAcadBlockReference2 08330c34>) (...) ...) ; block list
;
(setq BksCol (vla-get-blocks DbxDoc))
(foreach ForElm BksInf
(setq
BlkNam (car ForElm)
BlkDef (ALE_Utl_GetItem BksCol BlkNam) ; Obj definizione di blocco
BkDInP (safearray-value (vlax-variant-value (vla-get-Origin BlkDef))) ; InsertionPoint definizione di blocco
BlkIns (cadddr ForElm) ; Obj blocco inserito
BlkScl (vla-get-XScaleFactor BlkIns); scalaX blocco inserito
BkIInP (safearray-value (vlax-variant-value (vla-get-InsertionPoint BlkIns))); InsertionPoint blocco inserito
BkIAtt (vlax-invoke BlkIns 'GetAttributes); attributi blocco inserito - se si usa (vla-GetAttributes VlaObj) si ottiene un variant che bisogna trasformare e poi elaborare con vlax-for
)
(vlax-for ObjFor BlkDef ; attributi definizione di blocco
(if (= (vla-get-objectname ObjFor) "AcDbAttributeDefinition")
(setq BkDAtt (cons (list (vla-get-TagString ObjFor) ObjFor) BkDAtt))
)
)
; BkIAtt (#<VLA-OBJECT IAcadAttributeReference 000000003ce20898> #<VLA-OBJECT IAcadAttributeReference 000000003ce240d8> ...)
; BkDAtt (("FILE" #<VLA-OBJECT IAcadAttribute 000000003da926c8>) ("ACVER" #<VLA-OBJECT IAcadAttribute 000000003da90508>) ...)
(cond
( (> (length BkDAtt) (length BkIAtt))
(setq
NewBlk
(vla-InsertBlock
(vla-objectidtoobject DbxDoc (vla-get-ownerid BlkIns)) (vla-get-InsertionPoint BlkIns) (vla-get-Name BlkIns) BlkScl BlkScl BlkScl (vla-get-Rotation BlkIns)
)
)
(vla-put-Layer NewBlk (vla-get-Layer BlkIns))
(vla-put-Linetype NewBlk (vla-get-Linetype BlkIns))
(foreach ObjFor BkIAtt ; lista attributi blocco inserito con TAG
(setq AttLst (cons (list (vla-get-TagString ObjFor) ObjFor) AttLst))
)
(foreach ObjFor (vlax-invoke NewBlk 'GetAttributes); attributi NUOVO blocco inserito
(and
(setq AttInf (assoc (vla-get-TagString ObjFor) AttLst)) ; se trovo l'attributo nella lista attributi blocco inserito con TAG
(vla-Put-textstring ObjFor (vla-get-TextString (cadr AttInf)))
)
)
(vla-Delete BlkIns)
)
( T ; se gli attributi sono uguali o inferiori
(foreach ObjFor BkIAtt
(if (setq AttInf (assoc (vla-get-TagString ObjFor) BkDAtt)) ; se trovo l'attributo nella lista degli attributi in definizione di blocco
(progn
(setq AttObj (cadr AttInf))
(vla-put-Alignment ObjFor (vla-get-Alignment AttObj))
(vla-put-Layer ObjFor (vla-get-Layer AttObj))
(vla-put-Linetype ObjFor (vla-get-Linetype AttObj))
(vla-put-ScaleFactor ObjFor (vla-get-ScaleFactor AttObj))
(vla-put-StyleName ObjFor (vla-get-StyleName AttObj))
(vla-put-Rotation ObjFor (vla-get-Rotation AttObj))
(vla-put-Height ObjFor (* BlkScl (vla-get-Height AttObj)))
(setq
AtDInp (safearray-value (vlax-variant-value (vla-get-InsertionPoint AttObj)))
DeltaX (ALE_Attrib_CalcDeltaX BkIInP AtDInp BkDInP BlkScl)
DeltaY (ALE_Attrib_CalcDeltaY BkIInP AtDInp BkDInP BlkScl)
)
(vla-put-InsertionPoint ObjFor (vlax-3D-point (list DeltaX DeltaY 0)))
(setq
AtDInp (safearray-value (vlax-variant-value (vla-get-TextAlignmentPoint AttObj)))
DeltaX (ALE_Attrib_CalcDeltaX BkIInP AtDInp BkDInP BlkScl)
DeltaY (ALE_Attrib_CalcDeltaY BkIInP AtDInp BkDInP BlkScl)
); nei testi con acAlignmentLeft la proprietà seguente non è modificabile
(vl-catch-all-apply 'vlax-put-property (list ObjFor 'TextAlignmentPoint (vlax-3D-point (list DeltaX DeltaY 0))))
);progn
);if
);foreach BkIAtt
)
);cond
);foreach BksInf
(defun ALE_Attrib_CalcDeltaX (BkIInP AtDInp BkDInP BlkScl)
(+ (car BkIInP) (* (- (car AtDInp) (car BkDInP)) BlkScl))
)
;
(defun ALE_Attrib_CalcDeltaY (BkIInP AtDInp BkDInP BlkScl)
(+ (cadr BkIInP) (* (- (cadr AtDInp) (cadr BkDInP)) BlkScl))
)
(defun ALE_Utl_GetItem (VlaCol KeyNam / VlaObj)
(vl-catch-all-apply
'(lambda ( )
(setq VlaObj (vla-item VlaCol KeyNam))
)
)
VlaObj
)
Hey Marc, finally got a chance to test our the code you posted and it worked really well! Thanks for sharing. It fixed a problem I had with another LISP routine I'd written. :):)