Match properties for blocks

[stevedallas]

I need a lisp or lisps to match properties for blocks.

When I select a "source block", I will select multiple destination

blocks to match scale, colors, linetype, rotation, text style,

etc...everything.

Thanks

[rkmcswain]

I need a lisp or lisps to match properties for blocks.

When I select a "source block", I will select multiple destination

blocks to match scale, colors, linetype, rotation, text style,

etc...everything.

Thanks

 

Blocks don't have a text style property.

Color and Linetype should work using the MATCHPROP command.

 

That leaves something to match the scale and rotation......

 

You are not changing the properties of *all* insertions, correct?

[stevedallas]

Correct.

Just the blocks that I select.

[stevedallas]

Here is code that works...

 

;; Match Block

;; Matches properties from doner block to selected blocks

;; Properties include x,y,z scale factor, rotation, color, layer,

;; linetype, and linetypescale

(defun c:mb (/ srcblk ensel srcobj prop blkobj blk color linetype

rotation x-scale y-scale z-scale layer linetypescale lineweight plotstylename

)

 

(if (setq srcblk (car (entsel "\nSelect source block: ")))

(setq srcobj (vlax-ename->vla-object srcblk)

x-scale (vla-get-xscalefactor srcobj)

y-scale (vla-get-yscalefactor srcobj)

z-scale (vla-get-zscalefactor srcobj)

rotation (vla-get-rotation srcobj)

color (vla-get-color srcobj)

linetype (vla-get-linetype srcobj)

layer (vla-get-layer srcobj)

linetypescale (vla-get-linetypescale srcobj)

lineweight (vla-get-lineweight srcobj)

 

)

)

 

(while (progn

(prompt "\nSelect destination block: ")

(setq blk (ssget "+.:E:S"))

)

(setq blkobj (vlax-ename->vla-object (ssname blk 0)))

 

(prompt "\*** Got one. ***")

(vla-put-xscalefactor blkobj x-scale)

(vla-put-yscalefactor blkobj y-scale)

(vla-put-zscalefactor blkobj z-scale)

(vla-put-rotation blkobj rotation)

(vla-put-Color blkobj color)

(vla-put-Linetype blkobj linetype)

(vla-put-layer blkobj layer)

(vla-put-linetypescale blkobj linetypescale)

(vla-put-lineweight blkobj lineweight)

 

 

)

(princ)

)

(prompt "\*** Match Block Loaded, Enter MB to run. ***")

(princ)

[Temporary Creature]

hello-

umm...that sounds like exactly what I need

but I don't understand all the stuff you wrote on the bottom "code"

what is that?

when i see stuff like that I usually just zone out and back away slowly

looks complicated!

Do I copy it into notepad and "run" it like a lisp?

 

thanks-

TC

[kpblc]

You can also try this:

(defun c:mpr_block (/            *kpblc-activedoc*            selset
           ent            item
           _kpblc-layer-status-restore
           _kpblc-layer-status-save            *error*
           )
 (defun *error* (msg)
   (_kpblc-layer-status-restore)
   (vla-endundomark *kpblc-activedoc*)
   (princ msg)
   (princ)
   ) ;_ end of defun

 (defun _kpblc-layer-status-restore (/ item)
   (if    *kpblc-list-layer-status*
     (progn
   (foreach item *kpblc-list-layer-status*
     (vla-put-layeron (car item) (cdr (assoc "on" (cdr item))))
     (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
     (if (not (equal (vla-get-activelayer) (car item)))
       (vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
       ) ;_ end of if
     ) ;_ end of foreach
   (setq *kpblc-list-layer-status* nil)
   ) ;_ end of progn
     ) ;_ end of if
   ) ;_ end of defun
 (defun _kpblc-layer-status-save (layers-on / item)
   (if    *kpblc-list-layer-status*
     (setq *kpblc-list-layer-status* nil)
     ) ;_ end of if
   (vlax-for item (vla-get-layers)
     (setq *kpblc-list-layer-status*
        (append *kpblc-list-layer-status*
            (list
              (list item
                (cons "freeze" (vla-get-freeze item))
                (cons "lock" (vla-get-lock item))
                (cons "on" (vla-get-layeron item))
                ) ;_ end of list
              ) ;_ end of list
            ) ;_ end of append
       ) ;_ end of setq
     (if layers-on
   (progn
     (vla-put-layeron item :vlax-true)
     (vla-put-lock item :vlax-false)
     (if (not (equal (vla-get-activelayer) item))
       (vla-put-freeze item :vlax-false)
       ) ;_ end of if
     ) ;_ end of progn
   ) ;_ end of if
     ) ;_ end of vlax-for
   ) ;_ end of defun

 (vl-load-com)
 (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark *kpblc-activedoc*)
 (if (and (setq ent (entsel "\nSelect the block for source prop <Exit> : "))
      (= (cdr (assoc 0 (entget (car ent)))) "INSERT")
      (setq ent (vlax-ename->vla-object (car ent)))
      ) ;_ end of and
   (progn
     (_kpblc-layer-status-save t)
     (if (setq selset (ssget '((0 . "INSERT"))))
   (while (and selset
           (> (sslength selset) 0)
           ) ;_ end of and
     (setq item (ssname selset 0))
     (ssdel item selset)
     (foreach prop    '("color"        "layer"          "xscalefactor"
             "yscalefactor"    "zscalefactor"    "rotation"
             "linetype"        "lineweight"      "linetypescale"
             )
       (if    (and (vlax-property-available-p ent)
            (vlax-property-available-p (vlax-ename->vla-object item))
            ) ;_ end of and
         (vlax-put-property item prop (vlax-get-property ent prop))
         ) ;_ end of if
       ) ;_ end of foreach
     ) ;_ end of while
   ) ;_ end of if
     (_kpblc-layer-status-restore)
     ) ;_ end of progn
   ) ;_ end of if
 (vla-regen *kpblc-activedoc* acactiveviewport)
 (vla-endundomark *kpblc-activedoc*)
 (princ)
 ) ;_ end of defun

After you load this lisp, call it from command line as:

Command: mpr_block

[kpblc]

Thanks to Katty tested the code. Some stupid errors fixed:

(defun c:mpr_block (/              *kpblc-activedoc*
           selset          ent
           item          _kpblc-layer-status-restore
           _kpblc-layer-status-save
           *error*
           )
 (defun *error* (msg)
   (_kpblc-layer-status-restore)
   (vla-endundomark *kpblc-activedoc*)
   (princ msg)
   (princ)
   ) ;_ end of defun

 (defun _kpblc-layer-status-restore (/ item)
   (if    *kpblc-list-layer-status*
     (progn
   (foreach item *kpblc-list-layer-status*
     (vla-put-layeron (car item) (cdr (assoc "on" (cdr item))))
     (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
     (if (not (equal (vla-get-activelayer *kpblc-activedoc*) (car item)))
       (vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
       ) ;_ end of if
     ) ;_ end of foreach
   (setq *kpblc-list-layer-status* nil)
   ) ;_ end of progn
     ) ;_ end of if
   ) ;_ end of defun

 (defun _kpblc-layer-status-save (layers-on / item)
   (if    *kpblc-list-layer-status*
     (setq *kpblc-list-layer-status* nil)
     ) ;_ end of if
   (vlax-for item (vla-get-layers *kpblc-activedoc*)
     (setq *kpblc-list-layer-status*
        (append *kpblc-list-layer-status*
            (list
              (list item
                (cons "freeze" (vla-get-freeze item))
                (cons "lock" (vla-get-lock item))
                (cons "on" (vla-get-layeron item))
                ) ;_ end of list
              ) ;_ end of list
            ) ;_ end of append
       ) ;_ end of setq
     (if layers-on
   (progn
     (vla-put-layeron item :vlax-true)
     (vla-put-lock item :vlax-false)
     (if (not (equal (vla-get-activelayer *kpblc-activedoc*) item))
       (vla-put-freeze item :vlax-false)
       ) ;_ end of if
     ) ;_ end of progn
   ) ;_ end of if
     ) ;_ end of vlax-for
   ) ;_ end of defun

 (vl-load-com)
 (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark *kpblc-activedoc*)
 (if (and (setq ent (entsel "\nSelect the block for source prop <Exit> : "))
      (= (cdr (assoc 0 (entget (car ent)))) "INSERT")
      (setq ent (vlax-ename->vla-object (car ent)))
      ) ;_ end of and
   (progn
     (_kpblc-layer-status-save t)
     (if (setq selset (ssget '((0 . "INSERT"))))
   (while (and selset
           (> (sslength selset) 0)
           ) ;_ end of and
     (setq item (ssname selset 0))
     (ssdel item selset)
     (foreach prop    '("color"        "layer"          "xscalefactor"
             "yscalefactor"    "zscalefactor"    "rotation"
             "linetype"        "lineweight"      "linetypescale"
             )
       (if    (and (vlax-property-available-p ent prop t)
            (vlax-property-available-p (vlax-ename->vla-object item) prop t)
            ) ;_ end of and
         (vlax-put-property (vlax-ename->vla-object item) prop (vlax-get-property ent prop))
         ) ;_ end of if
       ) ;_ end of foreach
     ) ;_ end of while
   ) ;_ end of if
     (_kpblc-layer-status-restore)
     ) ;_ end of progn
   ) ;_ end of if
 (vla-regen *kpblc-activedoc* acactiveviewport)
 (vla-endundomark *kpblc-activedoc*)
 (princ)
 ) ;_ end of defun

[lmurphy]

Hey guys, thats great.....but

 

Can this be modified to work on dynamic blocks?

[jcap91163]

works very nice, many thanks

[alanjt]

Just for fun...

 

(defun c:BMP (/ obj pLst sLst ss)
 ;; Block Match Properties
 ;; Required Subroutines: AT:GetSel
 ;; Alan J. Thompson, 08.03.10
 (if
   (and
     (AT:GetSel
       entsel
       "\nSelect source block: "
       (lambda (x)
         (if
           (and (eq "INSERT" (cdr (assoc 0 (entget (car x)))))
                (zerop
                  (logand 45 (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 (entget (car x))))))))
                )
           )
            (setq obj (vlax-ename->vla-object (car x)))
         )
       )
     )
     (setq sLst (mapcar
                  (function (lambda (p)
                              (vl-catch-all-apply (function vlax-get-property) (list obj p))
                            )
                  )
                  (setq pLst '(Color Layer Linetype LinetypeScale Lineweight Material PlotStyleName
                               Rotation XEffectiveScaleFactor YEffectiveScaleFactor
                               ZEffectiveScaleFactor
                              )
                  )
                )
     )
     (setq ss (ssget "_:L" '((0 . "INSERT"))))
   )
    (progn
      (vlax-for x (setq ss (vla-get-activeselectionset
                             (cond (*AcadDoc*)
                                   ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
                                   )
                             )
                           )
                  )
        (mapcar
          (function (lambda (p s) (vl-catch-all-apply (function vlax-put-property) (list x p s))))
          pLst
          sLst
        )
      )
      (vla-delete ss)
    )
 )
 (princ)
)


(defun AT:GetSel (meth msg fnc / ent good)
 ;; meth - selection method (entsel, nentsel, nentselp)
 ;; msg - message to display (nil for default)
 ;; fnc - optional function to apply to selected object
 ;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (x) (eq (cdr (assoc 0 (entget (car x)))) "ARC")))
 ;; Alan J. Thompson, 05.25.10
 (setvar 'errno 0)
 (while (not good)
   (setq ent (meth (cond (msg)
                         ("\nSelect object: ")
                   )
             )
   )
   (cond
     ((vl-consp ent)
      (setq good (if (or (not fnc) (fnc ent))
                   ent
                   (prompt "\nInvalid object!")
                 )
      )
     )
     ((eq (type ent) 'STR) (setq good ent))
     ((setq good (eq 52 (getvar 'errno))) nil)
     ((eq 7 (getvar 'errno)) (setq good (prompt "\nMissed, try again.")))
   )
 )
)

Also, kbplc's is incredibly inefficient, since it retrieves the source object's properties each time it attempts to edit one of the selected blocks.

Edited August 3, 2010 by alanjt

[Lee Mac]

Al, I'm not sure, but would you want to use:

 

(zerop (logand 45 <dxf 70>))

 

?

[alanjt]

Al, I'm not sure, but would you want to use:

 

(zerop (logand 45 <dxf 70>))

?

Elaborate. I was under the impression that (logand 4 ...) would net me the XRefs.

 

Not a biggie, but please don't call me Al. I hate that.

[Lee Mac]

Not a biggie, but please don't call me Al. I hate that.

 

Apologies - it won't happen again.

 

Yeah, as I say I wasn't sure, but I saw it in an old Tony Tanzillo code, and who argues with that lol

[alanjt]

Apologies - it won't happen again.

 

Yeah, as I say I wasn't sure, but I saw it in an old Tony Tanzillo code, and who argues with that lol

No worries at all.

 

Yeah, you don't argue with Tony. Did he explain his reasoning or do you know why 45 is the choice?

[Lee Mac]

No worries at all.

 

Yeah, you don't argue with Tony. Did he explain his reasoning or do you know why 45 is the choice?

 

It was just a part of another code that I saw it in, so not a central point to comment about, but I should think:

 

45 = 32 + 8 + 4 + 1

32 = resolved xref
8 = xref overlay
4 = xref
1 = anonymous

 

*shrug*

[alanjt]

It was just a part of another code that I saw it in, so not a central point to comment about, but I should think:

 

45 = 32 + 8 + 4 + 1

32 = resolved xref
8 = xref overlay
4 = xref
1 = anonymous

*shrug*

Learning something new every day. Thanks for the info, Lee.

*Code Updated*

 

Of course, wouldn't it always be an XRef? So, my (/= 4 (logand 4... would work. Wouldn't it?

[Lee Mac]

Learning something new every day. Thanks for the info, Lee.

*Code Updated*

 

Of course, wouldn't it always be an XRef? So, my (/= 4 (logand 4... would work. Wouldn't it?

 

Logically I can't see why not, but I haven't experimented enough to be sure..

[alanjt]

Logically I can't see why not, but I haven't experimented enough to be sure..

That's what I was thinking. Each have the bit 4 for being an XRef, which is all I was checking (originally). Oh well, both work. I think I'll play with it a little tonight. Regardless, you provided useful information.

I am a little annoyed at myself for not really considering what you said, instead of changing my code willingly.

[Lee Mac]

I am a little annoyed at myself for not really considering what you said, instead of changing my code willingly.

 

"Question Everything".

[alanjt]

"Question Everything".

Any other time and I would have. I was too quick to take your word for it and it was time to go home (short day).

Oh well.