Lisp routine: Insert Block with attribute depending of another block attribute
Accepted solution
Ok, here it goes.
Quick 'n dirty code tailored for your specific block only. Changing the layer of the original block is not included yet, but to add remove the semicolon before the (vla-put-Layer ....) line and change the layer name to whatever you need.
Use the command TEST and select your existing block on the attribute (!).
(defun c:Test (/ ent obj att fieldcode)
(if
(and
(setq ent (entsel "\nSelect block: "))
(= (vla-get-ObjectName (setq obj (vlax-ename->vla-object (car ent)))) "AcDbBlockReference")
(= (vla-get-EffectiveName obj) "SPI-Datenextraktionspunkt-CM")
(setq att (nentselp (cadr ent)))
(= (vla-get-ObjectName (setq att (vlax-ename->vla-object (car att)))) "AcDbAttribute")
)
(progn
(setvar "ATTDIA" 0)
;(vla-put-Layer obj "LayerName")
(setq fieldcode (strcat "%<\\AcObjProp Object\(%<\\_ObjId " (itoa (vla-get-objectid att)) ">%\).TextString>%"))
(command "-INSERT" "SPI-Punkttest3" PAUSE "" "" "" fieldcode "")
(setvar "ATTDIA" 1)
)
)
)
try this:
You can change the global options in the code:
;;global data: (setq NameBlkExist "SPI-Datenextraktionspunkt-CM") (setq NameBlkNew "SPI-Punkttest3") (setq layerNoPrint "000-layerNoPrint") (setq IsField T) ....
Program:
;;============================= C:test0023 ====================================;;
;; Jose L. García G. - 27/09/17 ;;
;;=============================================================================;;
(defun C:test0023 (/ NameBlkExist NameBlkNew layerNoPrint IsField
idx ss lstss
;|Functions|; Blk2Blk get-atts
)
;;----------------------- get-atts ----------------------
(defun get-atts (blk / lst)
(if (and (= (vla-get-hasAttributes blk) :vlax-true)
(not (vl-catch-all-error-p
(setq lst (vl-catch-all-apply
'vlax-safeArray->list
(list (vlax-variant-value (vla-getAttributes blk))))))))
(setq lst (mapcar (function (lambda (Att)
(list (vla-get-tagstring Att)(vla-get-textstring Att) Att)
)) lst))
nil
);c.if
);c.defun
;;------------------------------- Blk2Blk ------------------------------
(defun Blk2Blk (eBlkExist / oBlk oBlkNew ptIns bX bY bZ bRot bLayer lAtts1 lAtts2 ERRMsg)
(setq ActDoc (vla-get-activedocument (vlax-get-acad-object)))
(setq ActSpace (vlax-get-property ActDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
(setq oBlk (vlax-ename->vla-object eBlkExist))
(setq ptIns (vla-Get-InsertionPoint oBlk))
(setq bX (vla-get-XEffectiveScaleFactor oBlk)
bY (vla-get-YEffectiveScaleFactor oBlk)
bZ (vla-get-ZEffectiveScaleFactor oBlk))
(setq bRot (vla-get-Rotation oBlk))
(setq bLayer (vla-get-Layer oBlk))
(cond
((vl-catch-all-error-p (vl-catch-all-apply (function vla-Item) (list (vla-get-Blocks ActDoc) NameBlkNew)))
(setq ERRMsg (strcat "ERROR: There is no block [" NameBlkNew "] in the document.."))
)
((not (setq oBlkNew (vla-InsertBlock ActSpace ptIns NameBlkNew bX bY bZ bRot)))
(setq ERRMsg (strcat "ERROR: Could not insert the block: [" NameBlkNew "]."))
)
(T
(vla-add (vla-get-layers ActDoc) layerNoPrint)
(vla-put-Layer oBlkNew bLayer)
(vla-put-Layer oBlk layerNoPrint)
(cond
((not (setq lAtts1 (get-atts oBlk)))
(setq ERRMsg (strcat "ALERT: Block [" NameBlkExist "] does not contain attributes."))
)
((not (setq lAtts2 (get-atts oBlkNew)))
(setq ERRMsg (strcat "ALERT: Block [" NameBlkNew "] does not contain attributes."))
)
(T
;;(("01" "EG-032" #<VLA-OBJECT IAcadAttributeReference 0000000039685788>)...)
(mapcar
(function
(Lambda (pAtt / pAtt2 fcode)
(setq fcode (strcat "%<\\AcObjProp Object\(%<\\_ObjId "
(itoa (vla-get-objectid (last pAtt)))
">%\).TextString>%"))
(if (setq pAtt2 (assoc (car pAtt) lAtts2))
(vla-put-TextString (last pAtt2)
(if IsField fcode (cadr pAtt))
)
)
)
)
lAtts1
);c.mapcar
)
);c.cond
)
);c.cond
ERRMsg
)
;;---------------------------- MAIN -------------------------
(setvar 'cmdecho 0)
;;global data:
(setq NameBlkExist "SPI-Datenextraktionspunkt-CM")
(setq NameBlkNew "SPI-Punkttest3")
(setq layerNoPrint "000-layerNoPrint")
(setq IsField T)
;;______________________________________
(setq idx 1)
(prompt (strcat "\nSelect blocks;[" NameBlkExist "]: "))
(cond
((setq ss (ssget (list '(0 . "INSERT")(cons 2 NameBlkExist))))
(setq lstss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(command-s "_.undo" "_BE")
(mapcar
(function
(lambda (eBlk / lAtts oBlk Result)
(if (setq Result (Blk2Blk eBlk))
(prompt (strcat "\n" Result))
)
(prompt (strcat "\rModifying Blocks: " (itoa idx)))
(setq idx (1+ idx))
)
)
lstss
);c.mapcar
(command-s "_.undo" "_E")
)
);c.cond
(princ)
);c defun
(princ)
