Map attributes from 1 block to another...

Discussion in 'AutoCAD' started by Cory McConnell, Aug 16, 2004.

  1. I am in need of some macro charity.<g>

    I have a block in mspace with attributes in it (lets say att a, att b, and
    att c). I want to copy the values from that block to a block in pspace with
    attributes in it (lets say att 1, att 2, att 3). I need them mapped att b -
    att1; att a - att 3; attc - att 2. (an example) The map will always be the
    same. I no nothing of program lisp or VBA. Can anybody help?
     
    Cory McConnell, Aug 16, 2004
    #1
  2. Cory McConnell

    T.Willey Guest

    If the blocks only have one instance, then it is pretty simple, but if more then one it could get ruff. How many attributes are you talking about?

    Tim
    If I have time I can help.
     
    T.Willey, Aug 16, 2004
    #2
  3. There is only 1 instance of each block. There are approxiamatly 20
    attributes in each block.
     
    Cory McConnell, Aug 17, 2004
    #3
  4. Cory McConnell

    Jürg Menzi Guest

    Hi Cory

    This function should do what you want. Replace the attribute tag and block
    names with the requested names.
    Code:
    (defun C:CopyAttVals ( / AcaDoc AttLst FltLst SrcBlk SrcObj SrcSet TagLst
    TarBlk TarLay TarObj TarSet TmpVal)
    (vl-load-com)
    (setq TagLst '(;From.......To
    ("ATT_A" . "ATT_1")
    ("ATT_B" . "ATT_2")
    ("ATT_C" . "ATT_3")
    )
    SrcBlk "SourceBlockName"
    TarBlk "TargetBlockName"
    FltLst '((0 . "INSERT") (66 . 1))
    )
    (cond
    ((not (setq SrcSet (ssget "X" (cons (cons 2 SrcBlk) FltLst))))
    (alert (strcat " Source block '" SrcBlk "' not found. "))
    )
    ((not (setq TarSet (ssget "X" (cons (cons 2 TarBlk) FltLst))))
    (alert (strcat " Target block '" TarBlk "' not found. "))
    )
    (T
    (setq AcaDoc (vla-get-ActiveDocument (vlax-get-acad-object))
    SrcObj (vlax-ename->vla-object (ssname SrcSet 0))
    TarObj (vlax-ename->vla-object (ssname TarSet 0))
    AttLst (vl-remove nil
    (mapcar
    '(lambda (l)
    (if (setq TmpVal (cdr (assoc (car l) TagLst)))
    (cons TmpVal (cdr l))
    )
    ) (MeGetAtts SrcObj)
    )
    )
    TarLay (vla-Item (vla-get-Layers AcaDoc) (vla-get-Layer TarObj))
    )
    (vla-StartUndoMark AcaDoc)
    (if (= (vla-get-Lock TarLay) :vlax-true)
    (progn
    (vla-put-Lock TarLay :vlax-false)
    (MeSetAtts TarObj AttLst)
    (vla-put-Lock TarLay :vlax-true)
    )
    (MeSetAtts TarObj AttLst)
    )
    (vla-EndUndoMark AcaDoc)
    )
    )
    (princ)
    )
    ;
    ; == Function MeGetAtts
    ; Reads all attribute values from a block
    ; Arguments [Typ]:
    ;   Obj = Object [VLA-OBJECT]
    ; Return [Typ]:
    ;   > Dotted pair list '(("Tag1" . "Val1")...) [LIST]
    ; Notes:
    ;   None
    ;
    (defun MeGetAtts (Obj)
    (mapcar
    '(lambda (Att)
    (cons
    (vla-get-TagString Att)
    (vla-get-TextString Att)
    )
    )
    (vlax-invoke Obj 'GetAttributes)
    )
    )
    ;
    ; == Function MeSetAtts
    ; Modifies attribute values in a block.
    ; Argumente [Type]:
    ;   Obj = Block object [VLA-OBJECT]
    ;   Lst = Attribute list '((Tag1 . Val1)...) [LIST]
    ; Return [Type]:
    ;   > Null
    ; Notes:
    ;   None
    ;
    (defun MeSetAtts (Obj Lst / AttVal)
    (mapcar
    '(lambda (l)
    (if (setq AttVal (cdr (assoc (vla-get-tagstring l) Lst)))
    (vla-put-textstring l AttVal)
    )
    )
    (vlax-invoke Obj 'GetAttributes)
    )
    (vla-update Obj)
    (princ)
    )
    
    Cheers
     
    Jürg Menzi, Aug 17, 2004
    #4
  5. Cory McConnell

    Jürg Menzi Guest

    Oops...

    Should be:
    Code:
    (defun C:CopyAttVals ( / AcaDoc AttLst FltLst SrcBlk SrcObj SrcSet TagLst
    TarBlk TarLay TarObj TarSet TmpVal)
    (vl-load-com)
    (setq TagLst '(;From.......To
    ("ATT_A" . "ATT_1")
    ("ATT_B" . "ATT_2")
    ("ATT_C" . "ATT_3")
    )
    SrcBlk "SourceBlockName"
    TarBlk "TargetBlockName"
    FltLst '((0 . "INSERT") (66 . 1))
    )
    (cond
    ((not (setq SrcSet (ssget "X" (cons (cons 2 SrcBlk) FltLst))))
    (alert (strcat " Source block '" SrcBlk "' not found. "))
    )
    ((not (setq TarSet (ssget "X" (cons (cons 2 TarBlk) FltLst))))
    (alert (strcat " Target block '" TarBlk "' not found. "))
    )
    (T
    (setq AcaDoc (vla-get-ActiveDocument (vlax-get-acad-object))
    SrcObj (vlax-ename->vla-object (ssname SrcSet 0))
    TarObj (vlax-ename->vla-object (ssname TarSet 0))
    TarLay (vla-Item (vla-get-Layers AcaDoc) (vla-get-Layer TarObj))
    )
    (foreach memb (MeGetAtts SrcObj)
    (if (setq TmpVal (cdr (assoc (car memb) TagLst)))
    (setq AttLst (cons (cons TmpVal (cdr memb)) AttLst))
    )
    )
    (vla-StartUndoMark AcaDoc)
    (if (= (vla-get-Lock TarLay) :vlax-true)
    (progn
    (vla-put-Lock TarLay :vlax-false)
    (MeSetAtts TarObj AttLst)
    (vla-put-Lock TarLay :vlax-true)
    )
    (MeSetAtts TarObj AttLst)
    )
    (vla-EndUndoMark AcaDoc)
    )
    )
    (princ)
    )
    ;
    ; == Function MeGetAtts
    ; Reads all attribute values from a block
    ; Arguments [Typ]:
    ;   Obj = Object [VLA-OBJECT]
    ; Return [Typ]:
    ;   > Dotted pair list '(("Tag1" . "Val1")...) [LIST]
    ; Notes:
    ;   None
    ;
    (defun MeGetAtts (Obj)
    (mapcar
    '(lambda (Att)
    (cons
    (vla-get-TagString Att)
    (vla-get-TextString Att)
    )
    )
    (vlax-invoke Obj 'GetAttributes)
    )
    )
    ;
    ; == Function MeSetAtts
    ; Modifies attribute values in a block.
    ; Argumente [Type]:
    ;   Obj = Block object [VLA-OBJECT]
    ;   Lst = Attribute list '((Tag1 . Val1)...) [LIST]
    ; Return [Type]:
    ;   > Null
    ; Notes:
    ;   None
    ;
    (defun MeSetAtts (Obj Lst / AttVal)
    (mapcar
    '(lambda (l)
    (if (setq AttVal (cdr (assoc (vla-get-tagstring l) Lst)))
    (vla-put-textstring l AttVal)
    )
    )
    (vlax-invoke Obj 'GetAttributes)
    )
    (vla-update Obj)
    (princ)
    )
    
    Cheers
     
    Jürg Menzi, Aug 17, 2004
    #5
  6. It works great thank you.
     
    Cory McConnell, Aug 17, 2004
    #6
  7. Cory McConnell

    Jürg Menzi Guest

    Welcome...¦-)

    Cheers
     
    Jürg Menzi, Aug 17, 2004
    #7
  8. It will save me alot of time converting Inventor files to dwgs.

    Is there a way to do the same thing with textstyles? Map several styles to
    another one?
     
    Cory McConnell, Aug 17, 2004
    #8
  9. Cory McConnell

    Jürg Menzi Guest

    Hi Cory

    Replace style names with the requested names.
    Code:
    (defun C:CopyTextStyle ( / AcaDoc SrcObj SrcSty TarObj TarSty)
    (vl-load-com)
    (setq AcaDoc (vla-get-ActiveDocument (vlax-get-acad-object))
    SrcSty "SourceStyleName"
    TarSty "TargetStyleName"
    )
    (cond
    ((not (setq SrcObj (MeGetTextStyle SrcSty AcaDoc)))
    (alert (strcat " Source text style '" SrcSty "' not found. "))
    )
    ((not (setq TarObj (MeGetTextStyle TarSty AcaDoc)))
    (alert (strcat " Target text style '" TarSty "' not found. "))
    )
    (T
    (vla-StartUndoMark AcaDoc)
    (vla-put-Height TarObj (vla-get-Height SrcObj))
    (vla-put-LastHeight TarObj (vla-get-LastHeight SrcObj))
    (vla-put-ObliqueAngle TarObj (vla-get-ObliqueAngle SrcObj))
    (vla-put-TextGenerationFlag TarObj (vla-get-TextGenerationFlag SrcObj))
    (vla-put-Width TarObj (vla-get-Width SrcObj))
    (vla-put-fontfile TarObj (vla-get-fontfile SrcObj))
    (vla-EndUndoMark AcaDoc)
    )
    )
    (princ)
    )
    ;
    ; -- Function MeGetTextStyle
    ; Returns the text style obect.
    ; Arguments [Typ]:
    ;   Sty = Style name
    ;   Acd = Active document object [VLA-OBJECT]
    ; Return [Typ]:
    ;   > Style object [VLA-OBJECT]
    ;   > False if style not exists
    ; Notes:
    ;   None
    ;
    (defun MeGetTextStyle (Sty Acd / StyObj)
    (vl-catch-all-error-p
    (vl-catch-all-apply
    (function
    (lambda ()
    (setq StyObj (vla-Item (vla-get-TextStyles Acd) Sty))
    )
    )
    )
    )
    StyObj
    )
    
    Cheers
     
    Jürg Menzi, Aug 20, 2004
    #9
Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments (here). After that, you can post your question and our members will help you out.