Copy block attributes from one block to another

[thorny]

Title Blocks.dwg

 

Hi. I am hoping that someone may be able to help me achieve copying and pasting attributes from one title block to another.

 

I have found a lisp which works to a certain degree, but has 2 issues:

1. You cannot copy and paste from a block in layout 1 to layout 2.
   
2. Our blocks have some duplicated attribute names eg 3xTitle & 2xSite
   

I have attached a dwg containing 2 of our borders and the lisp to help explain.

 

I understand that the duplicated attributes within each border may posses a challenge to overcome, but we have quite a lot of borders for various tasks and would be great if we didn't have to change the attribute names to eg. Title 1, Title 2, Title 3 etc...

 

Obviously if this cannot be overcome, but you can copy attributes across various layouts, that would be hugely advantagous in itself.

 

Cheers

test.lsp

[Tharwat]

This may help you with it , So check it out Buddy .

 

(defun c:Action (/ ss ssObj ss1 ssObj1 ssTag1)
;;;; Tharwat 02. 03. 2011
 (vl-load-com)
 (if (eq (progn (initget "Copy Paste")
                (setq ops (getkword "\n What to do [Copy,Paste]:"))
         )
         "Copy"
     )
   (progn
     (setq ss (car (nentsel "\n Select Block with Attributes: ")))
     (setq ssObj (vlax-ename->vla-object ss))
     (setq ssTag (vla-get-TextString ssObj))
   )
   (progn
     (setq ss1 (car (nentsel "\n Select Block to change: ")))
     (setq ssObj1 (vlax-ename->vla-object ss1))
     (setq ssTag1 (vla-put-TextString ssObj1 ssTag))
   )
 )
 (vla-regen (vla-get-activedocument (vlax-get-acad-object))
            acActiveViewport
 )
 (princ)
)

Tharwat

[thorny]

Hi Tharwat

 

Thanks for the code. However I cannot seem to run it. I have loaded it in using APPLOAD, but when I close the Appload Window I get "; error: malformed list on input" at the command line.

I have tried running typing "Action," but it doesn't work. Am I missing something simple here?

[Lee Mac]

Hi Thorny,

 

Nice to see a few other Brits around here

 

To my knowledge, you can't use LISP to manually select blocks in different layouts since upon switching layouts, the LISP is cancelled.

 

However, this offers another approach which will allow you to select a block and update all blocks with the same name (it should also hopefully work with your blocks with multiple tags with the same name).

 

Call with 'test':

 

(defun c:test ( / _remove1st source ss i ) (vl-load-com)
 ;; © Lee Mac 2011

 (defun _remove1st ( item lst )
   (if lst
     (if (equal item (car lst))
       (cdr lst)
       (cons (car lst) (_remove1st item (cdr lst)))
     )
   )
 )

 (if
   (setq source
     (LM:Select "\nSelect Source Attributed Block: "
       (function
         (lambda ( x )
           (and (eq "INSERT" (cdr (assoc 0 (entget x)))) (= 1 (cdr (assoc 66 (entget x)))))
         )
       )
       entsel
     )
   )
   (if
     (progn
       (ssdel source
         (setq ss
           (ssget "_X"
             (list (cons 0 "INSERT") (assoc 2 (entget source)) (cons 66 1))
           )
         )
       )
       (< 0 (setq i (sslength ss)))
     )
     (
       (lambda ( attribs / attribdata )
         (repeat i (setq attribdata attribs)
           (mapcar
             (function
               (lambda ( attrib / item )
                 (if (setq item (assoc (vla-get-TagString attrib) attribdata))
                   (progn
                     (vla-put-TextString attrib (cdr item))
                     (setq attribdata (_remove1st item attribdata))
                   )
                 )
               )
             )
             (vlax-invoke (vlax-ename->vla-object (ssname ss (setq i (1- i)))) 'GetAttributes)
           )
         )
         (princ (strcat "\n--> " (itoa (sslength ss)) " Block(s) Updated."))
       )
       (mapcar
         (function
           (lambda ( attrib )
             (cons (vla-get-TagString attrib) (vla-get-TextString attrib))
           )
         )
         (vlax-invoke (vlax-ename->vla-object source) 'GetAttributes)
       )
     )
     (princ "\n--> Only one instance of Source Block.")
   )
 )

 (princ)
)

(defun LM:Select ( msg pred fun / e ) (setq pred (eval pred))
 ;; © Lee Mac 2011
 
 (while
   (progn (setvar 'ERRNO 0) (setq e (car (fun msg)))      
     (cond
       ( (= 7 (getvar 'ERRNO))

         (princ "\n** Missed, Try again **")
       )
       ( (eq 'ENAME (type e))

         (if (and pred (not (pred e)))
           (princ "\n** Invalid Object Selected **")
         )
       )
     )
   )
 )
 e
)

(princ)

Regards,

 

Lee

Edited March 2, 2011 by Lee Mac

[BIGAL]

Heres the same thing almost in VBA the original idea behind it was a single title block change no matter how many title blocks the extra code allows for pick a block that identifies the block name hope all this makes sense. Just run the add_project_number it will work with your block, change DA1DRTXT to your block name.

 

Public Sub add_project_number()
' This Updates the project number
Dim SS As AcadSelectionSet
Dim Count As Integer
Dim FilterDXFCode(1) As Integer
Dim FilterDXFVal(1) As Variant
Dim attribs, newtext As Variant
Dim BLOCK_NAME As String
'On Error Resume Next
Dim startCH As Double
newtext = ThisDrawing.Utility.GetString(True, "Enter new project code : ")
FilterDXFCode(0) = 0
FilterDXFVal(0) = "INSERT"
FilterDXFCode(1) = 2
FilterDXFVal(1) = "DA1DRTXT"
BLOCK_NAME = "DA1DRTXT"
Set SS = ThisDrawing.SelectionSets.Add("issued")
SS.Select acSelectionSetAll, , , FilterDXFCode, FilterDXFVal

For Cntr = 0 To SS.Count - 1
  attribs = SS.Item(Cntr).GetAttributes
       
       
       attribs(1).TextString = newtext
               attribs(1).Update
        
Next Cntr
ThisDrawing.SelectionSets.Item("issued").Delete

End Sub

 

and

Function Getpitname(Newpitname As String) As String
Dim PitNameSelect As AcadObject
Dim pitattribs As Variant

ThisDrawing.Utility.GetEntity PitNameSelect, basepnt, "pick pit name : "
If PitNameSelect.ObjectName = "AcDbText" Then
 Getpitname = PitNameSelect.TextString
End If
If PitNameSelect.ObjectName = "AcDbBlockReference" Then
 pitblname = PitNameSelect.Name   ' RETURNS BLOCK NAME
 pitattribs = PitNameSelect.GetAttributes
 Getpitname = pitattribs(0).TextString
End If

End Function

 

you need to change the line newtext = ThisDrawing.Utility.GetString(True, "Enter new project code : ") to

 

Dim PitNameSelect As AcadObject
ThisDrawing.Utility.GetEntity PitNameSelect, basepnt, "pick pit name : "
Newpitname = "1"  'dummy to pass then return changed
pitname = Getpitname(Newpitname)
'Call Getpitname(pitname)
MsgBox "pitname selected is " & pitname

[Tharwat]

Hi Tharwat

 

Thanks for the code. However I cannot seem to run it. I have loaded it in using APPLOAD, but when I close the Appload Window I get "; error: malformed list on input" at the command line.

I have tried running typing "Action," but it doesn't work. Am I missing something simple here?

 

That's for sure that you have missed one of the parenthesis while copying codes to your Cad , and that might be the last bracket I guess .

 

Retry it and good luck

 

Tharwat

[alanjt]

May be of interest...

 

http://www.cadtutor.net/forum/showthread.php?48397-Copy-all-attributes...

[thorny]

Thanks for all the replies. Unfortunately nothing is quite working specifically for what we need although the lisps you have provided are great in their own rights. The bit that is not quite working is copying and pasting attibutes from one block to another (with different names), whilst swithing layouts. Swithing the layouts always terminates the lisps. The closest routine I found was http://www.cadtutor.net/forum/showthread.php?48397-Copy-all-attributes. Thanks alanjt for this. Is there anyway of switching between layouts whilst in a lisp? Or is there a way to update the attibutes globally (even if the blocks have different names), something similar to the ATTEDIT command, but not having to select the block?

[Lee Mac]

Thorny,

 

Mine will currently update blocks of the same name, but you can add other block names to the filter:

 

(defun c:test ( / _remove1st source ss i ) (vl-load-com)
 ;; © Lee Mac 2011

 (defun _remove1st ( item lst )
   (if lst
     (if (equal item (car lst))
       (cdr lst)
       (cons (car lst) (_remove1st item (cdr lst)))
     )
   )
 )

 (if
   (setq source
     (LM:Select "\nSelect Source Attributed Block: "
       (function
         (lambda ( x )
           (and (eq "INSERT" (cdr (assoc 0 (entget x)))) (= 1 (cdr (assoc 66 (entget x)))))
         )
       )
       entsel
     )
   )
   (if
     (progn
       (ssdel source
         (setq ss
           (ssget "_X"
             (list (cons 0 "INSERT") (cons 2 (strcat [color=red](cdr (assoc 2 (entget source)))[/color] [color=green]",BLOCK2,BLOCK3"[/color])) (cons 66 1))
           )
         )
       )
       (< 0 (setq i (sslength ss)))
     )
     (
       (lambda ( attribs / attribdata )
         (repeat i (setq attribdata attribs)
           (mapcar
             (function
               (lambda ( attrib / item )
                 (if (setq item (assoc (vla-get-TagString attrib) attribdata))
                   (progn
                     (vla-put-TextString attrib (cdr item))
                     (setq attribdata (_remove1st item attribdata))
                   )
                 )
               )
             )
             (vlax-invoke (vlax-ename->vla-object (ssname ss (setq i (1- i)))) 'GetAttributes)
           )
         )
         (princ (strcat "\n--> " (itoa (sslength ss)) " Block(s) Updated."))
       )
       (mapcar
         (function
           (lambda ( attrib )
             (cons (vla-get-TagString attrib) (vla-get-TextString attrib))
           )
         )
         (vlax-invoke (vlax-ename->vla-object source) 'GetAttributes)
       )
     )
     (princ "\n--> Only one instance of Source Block.")
   )
 )

 (princ)
)

(defun LM:Select ( msg pred fun / e ) (setq pred (eval pred))
 ;; © Lee Mac 2011
 
 (while
   (progn (setvar 'ERRNO 0) (setq e (car (fun msg)))      
     (cond
       ( (= 7 (getvar 'ERRNO))

         (princ "\n** Missed, Try again **")
       )
       ( (eq 'ENAME (type e))

         (if (and pred (not (pred e)))
           (princ "\n** Invalid Object Selected **")
         )
       )
     )
   )
 )
 e
)

(princ)

 

Shown in red is the name of the selected block, and shown in green are additional blocks to be updated.

[alanjt]

Thanks for all the replies. Unfortunately nothing is quite working specifically for what we need although the lisps you have provided are great in their own rights. The bit that is not quite working is copying and pasting attibutes from one block to another (with different names), whilst swithing layouts. Swithing the layouts always terminates the lisps. The closest routine I found was http://www.cadtutor.net/forum/showthread.php?48397-Copy-all-attributes. Thanks alanjt for this. Is there anyway of switching between layouts whilst in a lisp? Or is there a way to update the attibutes globally (even if the blocks have different names), something similar to the ATTEDIT command, but not having to select the block?

 

On mine, you could just type "ALL" when it comes to the multiple selection of blocks to update. This is a little shaky when you are NOT filtering based on matching block name, and will update if has matching attribute tag.

[alanjt]

Oop, looks like Lee may have given you the answer.

[thorny]

Lee

 

That's excellent. I have added names of the blocks to update and all works perfectly. Thanks ever so much for you help. Thanks also to Alan. Big thumbs up

[Lee Mac]

Good to hear mate! Happy to help out

[alanjt]

Ditto......

Good to hear mate! Happy to help out

[AaronHolmes]

Thanks again Lee, - Adding the various Title Block names, (with identically named variables) to the green sections above copied the filled in title block to the ones that were still blank. Another timesaver! //Aaron.

[Lee Mac]

I'm pleased to hear that my old code posts are still proving useful!

Glad you could make use of the program Aaron.