AutoCAD Lisp Routine to change all attributes / text to a style

[Lawrst]

Hi all,

 

I am wondering if you could help me with a conundrum I am having.

 

We have a large library of custom blocks we have made, within them are blocks that have different sized text and attributes.

 

Not all of these heights are linked to the style as they have had properties changed manually.

 

I have had a directive to change these to a uniform size for our drawings.

It seems to be a case for a lisp, I'm new to using these and have modified one I found online to the following, and i have done something wrong.

 

(defun C:CHANGESTYLE (/ entities len count ent ent_data ent_name new_style_name)

(command "STYLE" "Company_Name" "Arial Narrow.ttf" "" "" "" "" "")
(setq entities (ssget "x" '((0 . "attdef")))
     len      (sslength entities)
     count 0
);setq 

(while (< count len)
      (setq ent      (ssname entities count) 
            ent_data (entget ent)
            ent_name (cdr (assoc 7 ent_data))
      );setq

(setq new_style_name (cons 7 "Company_Name"))
(setq ent_data (subst new_style_name (assoc 7 ent_data) ent_data))
(entmod ent_data)

(setq count (+ count 1))
);while

(princ)

);defun

 

Any help would be greatly appreciated.

Edited February 5, 2018 by SLW210
CODE TAGS!

[StevJ]

As I understand, the LT version of Autocad doesn't natively support LISP.

 

Steve

[Lawrst]

Sorry,

 

I now have access to a full version of autoCAD, have updated my profile.

[rlx]

(defun c:changestyle  (/ entities len count ent ent_data ent_name new_style_name)
 (command "STYLE" "Company_Name" "Arial Narrow.ttf" "" "" "" "" "")
 (if (setq entities (ssget "x" '((0 . "attdef"))))
   (progn
     (setq len (sslength entities) count 0)
     (while (< count len)
       (setq ent (ssname entities count) ent_data (entget ent) ent_name (cdr (assoc 7 ent_data))
               new_style_name (cons 7 "Company_Name") ent_data (subst new_style_name (assoc 7 ent_data) ent_data))
       (entmod ent_data) (setq count (+ count 1))))
   (princ "\nNo valid objects (ATTDEF) found in this drawing")
 )
 (princ)
)

gr. Rlx

[BIGAL]

Lawrst

 

Rlx has fixed (setq entities (ssget "x" '((0 . "attdef")))) now has correct number of brackets

 

Rlx (setq entities (ssget "x" '((0 . "attdef")))) returns nil are you running in block editor ? Need to run in the dwg ! Just pick text in block editor use "properties" change to arial narrow no need for a lisp. Dont forget attsync.

 

Been playing with changing block table

(setq doc (vla-get-activedocument (vlax-get-acad-object)))

(vlax-for blk (vla-get-blocks doc)
(princ (strcat "\n " (vla-get-name blk)))
; check hasattributes
; go inside block and look at "Items"
; change stylename
)

[rlx]

@bigal, oh I see more coming already haha. Routine will only work when you are in the drawing of the symbol itself else ssget will allways return nil. If OP want it to run it in drawing with already symbols in it you will have to scan first for insert and then attrib... but this is a learning site and not a shopping site

 

 

gr. Rlx

[SLW210]

Please read the Code Posting Guidelines, your Code should be in Code Tags (you used Quote Tags).[NOPARSE]

Your Code Here[/NOPARSE]

=

Your Code Here

[rlx]

if you want to process entire folder at once you can try this , ink is still wet and I hope I didn't forget to include any of my automaticly loaded library functions this time.

 

; change text style - written by rlx 2 feb 2018 for Lawrst on CadTutor
; uses odbx to process entire folder , type 'cts' on commandline to start program
(defun c:cts (/ err acapp actdoc actspace acdocs all-open objdbx sf dwg-list start) (_init) (_exit) (terpri) (princ))

(defun change_text_style  ( $dwg / odbxdoc acstyles style-obj fnt layout obj o-name bn bn-list ent)
 (if (and (setq odbxdoc (odbx_open $dwg)) (setq acstyles (vla-get-textstyles odbxdoc))
   (setq style-obj (vla-add acstyles "Company_Name")) (setq fnt (findfile "C:\\Windows\\Fonts\\arialn.ttf")))
   (progn
     (vla-put-fontfile style-obj fnt)
     (vlax-for layout (vla-get-layouts odbxdoc)
       (vlax-for obj (vla-get-block layout)
         (cond
           ; remove "AcDbText" "AcDbMText" to NOT update (m)text's
           ((member (vla-get-objectname obj) '("AcDbText" "AcDbMText" "AcDbAttributeDefinition"))
            (vla-put-StyleName obj "Company_Name"))
           ((= (vla-get-objectname obj) "AcDbBlockReference")
            (mapcar '(lambda(x) (vla-put-StyleName x "Company_Name")) (get-block-ent obj)))
         )
       )
     )
     (vl-catch-all-error-p (vl-catch-all-apply 'vla-saveas (list odbxdoc $dwg)))
   )
 )
)
(defun get-block-ent ( b / bn lst block ent)
 (setq bn (vla-Get-EffectiveName b))
 ;;; get attributes
 (if (eq :vlax-true (vla-get-HasAttributes b))(setq lst (vlax-invoke b 'GetAttributes)))
 ;;; get text entities - just remove next 4 lines to NOT update (m)text
 (vlax-for block (vla-get-Blocks odbxdoc)
   (if (eq (vla-get-name block) bn)
     (vlax-for ent block (if (member (vla-get-objectname ent) '("AcDbText" "AcDbMText")) (setq lst (cons ent lst)))))
 )
 lst
)

 
;--- Init ----------------------------------------------- Begin of Init section -------------------------------------------------- Init ---
(defun _init  ()
 (vl-load-com)
 (setq err *error*)
 (defun *error* (s) (princ s) (_exit))
 (defun _exit () (odbx_releaseall) (setq *error* err))
 (odbx_init)
 (if (and (setq sf (getfolder "Select source folder for drawings")) (vl-consp (setq dwg-list (fido sf))))
   (progn (setq start (car (_vl-times)))
   (princ (strcat "\nProcessing " (setq l (itoa (length dwg-list))) " drawings..."))
   (foreach dwg dwg-list (change_text_style dwg))
   (princ (strcat "\n\nProcessed " l " drawings in " (rtos (/ (- (car (_vl-times)) start) 1000.) 2 4) " secs.")))
   (princ "\nNo files to process...")
 )
)
;--- Init ------------------------------------------------ End of Init section --------------------------------------------------- Init ---

;--- Scripting Object --------------------------------- Begin of Scripting Object ------------------------------------ Scripting Object ---
; Thanks to TonyT - just compressed and tweaked it a little bit
(defun load_fso_scripting  (/ server fso:progid fso:prefix)
 (setq fso:progid "Scripting.FileSystemObject" fso:prefix "wsh-")
 (if (not wsh-get-drives)
   (if (not (setq server (cogetclassserver fso:progid))) (alert "Error: Windows Scripting Host is not installed")
     (vlax-import-type-library :tlb-filename server :methods-prefix fso:prefix :properties-prefix fso:prefix :constants-prefix
(strcat ":" fso:prefix)))))
(defun progid->clsid (progid) (vl-registry-read (strcat "HKEY_CLASSES_ROOT\\" progid "[url="file://\\CLSID"]\\CLSID[/url]")))
(defun cogetclassserver (progid) (cogetclassproperty progid "InprocServer32"))
(defun cogetclassproperty  (progid property / clsid)
 (if (setq clsid (progid->clsid progid)) (vl-registry-read (strcat "HKEY_CLASSES_ROOT\\CLSID\\" clsid "\\" property))))
; Find Drawing Objects - test : (setq lst (fido (dos_path "c:/temp/lisp"))) works also with networkpaths
(defun fido  ($f / fso fld rslt)
 (load_fso_scripting) (setq fso (vla-getinterfaceobject (vlax-get-acad-object) "Scripting.FileSystemObject"))
 (setq fld  (wsh-getfolder fso $f) rslt (fifo fld "*.dwg"))(vlax-release-object fld)(vlax-release-object fso)  rslt)
; find in folders fl=file ,fls=files, sf=subfolder, sfl=subfolderlist, res=result
(defun fifo  (%dir %ext / fl fls sf sfl res)
 (vlax-for fl (setq fls (wsh-get-files %dir))
   (if (wcmatch (strcase (wsh-get-name fl) t) %ext) (setq res (cons (wsh-get-path fl) res)))(vlax-release-object fl))
 (vlax-release-object fls)
 (vlax-for sf (setq sfl (wsh-get-subfolders %dir)) (setq res (append res (fifo sf %ext)))(vlax-release-object sf))
 (release_me (list sfl)) res)
;--- Scripting Object ---------------------------------- End of Scripting Object ------------------------------------- Scripting Object ---


;--- Odbx ------------------------------------------------- Begin Odbx Section --------------------------------------------------- Odbx ---
(defun odbx_init  (/ acver)
 (setq acapp (vlax-get-acad-object) actdoc (vla-get-activedocument acapp) actspace (vla-get-modelspace actdoc)
acdocs (vla-get-documents acapp) acver (atoi (getvar "ACADVER"))
all-open (vlax-for dwg acdocs (setq all-open (cons (strcase (vla-get-fullname dwg)) all-open)))
objdbx (vl-catch-all-apply 'vla-getinterfaceobject
  (list acapp (if (< acver 16) "objectdbx.axdbdocument" (strcat "objectdbx.axdbdocument." (itoa acver))))))
 (if (or (void objdbx) (vl-catch-all-error-p objdbx)) (setq objdbx nil)))
(defun odbx_releaseall ()
 (mapcar '(lambda (x) (if (and (= 'vla-object (type x)) (not (vlax-object-released-p x)))(vlax-release-object x))(set (quote x) nil))
   (list odbxdoc acdocs objdbx actspace actdoc acapp)) (gc))
(defun odbx_open  (dwg)
 (if objdbx (if (member (strcase dwg) all-open)
       (odbx_open_copy (findfile dwg))(vl-catch-all-apply 'vla-open (list objdbx (findfile dwg))))) objdbx)
(defun odbx_open_copy  (dwg / copy)
 (vl-file-copy (findfile dwg) (setq copy (vl-filename-mktemp nil nil ".dwg")))(vla-open objdbx (findfile copy))  objdbx)
;--- Odbx -------------------------------------------------- End Odbx Section ---------------------------------------------------- Odbx ---

;--- + + + --------------------------------------------- Begin of tiny lisp section --------------------------------------------- + + + ---
(defun wait  (sec / stop) (setq stop (+ (getvar "DATE") (/ sec 86400.0))) (while (> stop (getvar "DATE"))))
(defun void  (x) (if (member x (list "" " " "  " "   " "       " nil '())) t nil))
(defun e2v (e)(vlax-ename->vla-object e)) ;||; (defun v2e (o)(vlax-vla-object->ename o)) ;||; (defun _type (e)(cdr (assoc 0 (entget e))))
(defun release_me  (lst)
 (mapcar '(lambda (x)(if (and (= 'vla-object (type x))(not (vlax-object-released-p x)))(vlax-release-object x))(set (quote x) nil)) lst))
(defun getfolder  (msg / fl sh)
 (if (and (setq sh (vlax-create-object "Shell.Application"))(setq fl (vlax-invoke sh 'browseforfolder 0 msg 0 "")))
   (setq fl (vlax-get-property (vlax-get-property fl 'self) 'path))(setq fl nil))(release_me (list sh)) fl)
(defun get_block_name (b)
 (cond ((vlax-property-available-p b 'effectivename) (vla-get-effectivename b)) ((vlax-property-available-p b 'name) (vla-get-name b))))
; make sure path is corect for scripting object (dos_path (strcat (getvar "dwgprefix") (getvar "dwgname")))
(defun dos_path  ($p) (if (= (type $p) 'str) (strcase (vl-string-translate "/" "\\" $p)) ""))
;--- + + + ---------------------------------------------- End of tiny lisp section ---------------------------------------------- + + + ---
(princ "\nRlx 2 feb 2018 : Type 'CTS' on commandline to start program\n")
(princ)

Updated code and think (hope) it now functions as expected. It will change all attributes and (m)text so enable / or disable filters to your need.

 

 

gr. Rlx

Edited February 2, 2018 by rlx

[Grrr]

why can't I acces a block reference with odbx?

 

Hi Rlx,

I'm not sure what do you mean by that - could you provide an example how you do it normally (without odbx).

[rlx]

Hi Rlx,

I'm not sure what do you mean by that - could you provide an example how you do it normally (without odbx).

 

 

normaly you can use

 (vlax-for layout (vlax-for object (vlax-for ent (... etc 

but in odbx (see line 15 in code above) this obviously doesn't work (so I disabled this option for now by putting xxAcDbBlockReference , with the 2 x's in front). This only seems to work on the blockdefinition (line 18 in code).

 

 

That's why I moved on with the next condition and use the vlax-invoke 'getattributes version (line 22 in code)

 

 

gr. Rlx

[Grrr]

Rlx,

Block references are not treated as collection objects (they don't have the 'Count property).

 

So if you try:

(setq blkref (vlax-ename->vla-object (car (entsel "\nPick Block reference: "))))
(vlax-for o blkref
 (print o)
)

 

It should error-out with:

Error: bad argument type: VLA-object collection: #<VLA-OBJECT IAcadBlockReference 0000008a2cc23a68>

 

 

So to sum-up:

(if (vlax-property-available-p obj 'Count)
 (princ "\nObj is collection.")
 (princ "\nObj is not a colletion.")
)

 

Or I'm missing something..

[rlx]

Rlx,

Block references are not treated as collection objects (they don't have the 'Count property). Or I'm missing something..

 

 

No , that's exactly the problem. So I can change the style for the block definition and when I open the processed drawing and insert a new block, it's attributes will have the new style. But existing blocks will need attsync.

 

 

p.s. I was just thinking , suppose I only want to update the style for certain attributes for certain blocks where a certain attribute has a certain value...

[Grrr]

So I can change the style for the block definition and when I open the processed drawing and insert a new block, it's attributes will have the new style. But existing blocks will need attsync.

 

But you are acessing the block definition then - which is a collection, then you redefine it in the new drawing by inserting that block reference (which contains the new blkdef).

 

Or you mean if the block definition is nested (which contains block references) - then again you'll need to access the definitions from the references (and a recursive technique like this would be required).

[rlx]

But you are acessing the block definition then - which is a collection, then you redefine it in the new drawing by inserting that block reference (which contains the new blkdef).

 

Or you mean if the block definition is nested (which contains block references) - then again you'll need to access the definitions from the references (and a recursive technique like this would be required).

 

 

I admit , most of it is purely academic and may or may not be of any practical use but sometimes I want more control than I need at the time, , just a case of 'what if in the future I would want to be able to do this of that' youknow... anyway , thanks for your input , always appreciated :-)

 

 

gr. Rlx

[Grrr]

No worries Rlx,

At one point I was curious about this too - could one iterate over a block reference's graphical objects (like LINEs/CIRCLEs etc..) (and without accessing its block definition).

But the closest thing I still know is via the EXPLODE method/command, just to extract some data from the resulting objects (and depending on the routine erase the exploded geometry).

[rlx]

No worries Rlx,

At one point I was curious about this too - could one iterate over a block reference's graphical objects (like LINEs/CIRCLEs etc..) (and without accessing its block definition).

But the closest thing I still know is via the EXPLODE method/command, just to extract some data from the resulting objects (and depending on the routine erase the exploded geometry).

 

 

 

The idea was to be able to update only the attributes of certain blocks and not all of them but the getattributes method works just as well I suppose. And now hoping OP has some use for it...

 

 

gr. Rlx

[Grrr]

Ah, now I see what you were trying - indeed seems a weird failure.

Maybe try it like this:

(vlax-for obj (vla-get-block layout)
 ; do stuff and obtain bn-list
)

(setq Blks (vla-get-Blocks odbxdoc))
(foreach blkname bn-list
 (vlax-for blkdef (vla-Item Blks blkname)
   (vlax-for obj blkdef
     (and 
       (vlax-write-enabled-p obj)
       (vlax-property-available-p obj 'StyleName)
       (vla-put-StyleName obj "Company_Name")
     ); and
   ); vlax-for obj
 ); vlax-for blkdef
); foreach

[rlx]

nope... same err... in the back of my head I was thinking about object-owner / id ... I vaguely remember reading something like that once... wel , it will come to mind , someday.

 

 

 

Think I've nailed it and have updated the code. I just scan all the objects ...

 

 

gr.Rlx

Edited February 2, 2018 by rlx

[Grrr]

Impressive coding, Rlx!

 

BTW here are 2c about the voidp function you use:

(defun void (x) (or (not x) (= "" x) (and (eq 'STR (type x)) (not (vl-remove 32 (vl-string->list x))))))

_$ (mapcar 'void (list nil "" " " "  " 123 "str" "                            "))
(T T T T nil nil T)

[rlx]

Impressive coding, Rlx!

 

BTW here are 2c about the voidp function you use:

(defun void (x) (or (not x) (= "" x) (and (eq 'STR (type x)) (not (vl-remove 32 (vl-string->list x))))))

_$ (mapcar 'void (list nil "" " " "  " 123 "str" "                            "))
(T T T T nil nil T)

 

thanx Grrr. In the end (or should I say begin) the problem was the difference between vla-get-block or vla-get-blocks... one stupid letter...

 

Yeah , my void only goes so many levels deep in an empty string that was because I wrote it before vlisp existed and before vl-string->list / -trim etc existed. And still it has served me well all the these years , pure nostalgia