Jump to content

list to globally change text height & width factor


The Courage Dog

Recommended Posts

Hi, is anybody who has the lisp routine that can globally change the height & width factor of text, mtext and attrbiutes in a block:(. Your help is much appreciated.

 

Thanks,

courage dog

Link to comment
Share on other sites

This is a crude way to change it in both the block definition, and in the existing Inserts.

 

Be careful with pre-formatted MText though.

 

(defun c:Redefine_Block_Text (/ *error* itemp GetName ENT OBJ UFLAG)
 (vl-load-com)
 ;; Lee Mac  ~  11.03.10

 (defun *error* (msg)
   (and uFlag (vla-EndUndoMark *doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))

 (defun itemp (collection item / result)
   (if (not (vl-catch-all-error-p
              (setq result (vl-catch-all-apply (function vla-item)
                             (list collection item)))))
       result))
 
 (setq *doc (cond (*doc) ((vla-get-ActiveDocument
                            (vlax-get-acad-object)))))

 (setq GetName (lambda (obj) (if (vlax-property-available-p obj 'EffectiveName)
                               (vla-get-EffectiveName obj)
                               (vla-get-Name obj))))

 (or *hdef* (setq *hdef* 1.0))
 (or *twid* (setq *twid* 1.0))

 (while
   (progn
     (setq ent (car (entsel "\nSelect Block to Change: ")))

     (cond (  (eq 'ENAME (type ent))

              (if (eq "AcDbBlockReference"
                      (vla-get-Objectname
                        (setq obj (vlax-ename->vla-object ent))))
                (progn
                  (setq uFlag (not (vla-StartUndoMark *doc)))

                  (initget 6)
                  (setq *hdef* (cond ((getdist "\nSpecify New Text Height: "))   (*hdef*)))
                  
                  (initget 6)
                  (setq *twid* (cond ((getdist "\nSpecify Text Width Factor: ")) (*twid*)))

                  (if (ssget "_X" (list (cons 0 "INSERT") (cons 2 (GetName obj)) (cons 66 1)))
                    (progn
                      (vlax-for sObj (setq ss (vla-get-ActiveSelectionSet *doc))
                        
                        (foreach att (append (vlax-invoke sObj 'GetAttributes)
                                             (vlax-invoke sObj 'GetConstantAttributes))

                          (vla-put-Height att *hdef*)

                          (if (eq :vlax-false (vla-get-MTextAttribute att))
                            (vla-put-ScaleFactor att *twid*)
                            (vla-put-TextString att (strcat "{\\W" (vl-princ-to-string *twid*) ";"
                                                            (vla-get-TextString att) "}")))))
                      (vla-delete ss)))

                  (vlax-for sub (itemp (vla-get-Blocks *doc) (GetName obj))

                    (cond (  (vl-position (vla-get-ObjectName sub) '("AcDbText" "AcDbAttributeDefinition"))

                             (vla-put-Height sub *hdef*)
                             (vla-put-ScaleFactor sub *twid*))

                          (  (eq "AcDbMText" (vla-get-ObjectName sub))

                             (vla-put-Height sub *hdef*)
                             (vla-put-TextString sub (strcat "{\\W" (vl-princ-to-string *twid*) ";"
                                                             (vla-get-TextString sub) "}")))))

                  (setq uFlag (vla-EndUndomark *doc))
                  (vla-Regen *doc AcActiveViewport))

                (princ "\n** Object Must be a Block **"))))))
 (princ))      

Link to comment
Share on other sites

This is a crude way to change it in both the block definition, and in the existing Inserts.

 

Be careful with pre-formatted MText though.

 

(defun c:Redefine_Block_Text (/ *error* itemp GetName ENT OBJ UFLAG)
 (vl-load-com)
 ;; Lee Mac  ~  11.03.10

 (defun *error* (msg)
   (and uFlag (vla-EndUndoMark *doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))

 (defun itemp (collection item / result)
   (if (not (vl-catch-all-error-p
              (setq result (vl-catch-all-apply (function vla-item)
                             (list collection item)))))
       result))

 (setq *doc (cond (*doc) ((vla-get-ActiveDocument
                            (vlax-get-acad-object)))))

 (setq GetName (lambda (obj) (if (vlax-property-available-p obj 'EffectiveName)
                               (vla-get-EffectiveName obj)
                               (vla-get-Name obj))))

 (or *hdef* (setq *hdef* 1.0))
 (or *twid* (setq *twid* 1.0))

 (while
   (progn
     (setq ent (car (entsel "\nSelect Block to Change: ")))

     (cond (  (eq 'ENAME (type ent))

              (if (eq "AcDbBlockReference"
                      (vla-get-Objectname
                        (setq obj (vlax-ename->vla-object ent))))
                (progn
                  (setq uFlag (not (vla-StartUndoMark *doc)))

                  (initget 6)
                  (setq *hdef* (cond ((getdist "\nSpecify New Text Height: "))   (*hdef*)))

                  (initget 6)
                  (setq *twid* (cond ((getdist "\nSpecify Text Width Factor: ")) (*twid*)))

                  (if (ssget "_X" (list (cons 0 "INSERT") (cons 2 (GetName obj)) (cons 66 1)))
                    (progn
                      (vlax-for sObj (setq ss (vla-get-ActiveSelectionSet *doc))

                        (foreach att (append (vlax-invoke sObj 'GetAttributes)
                                             (vlax-invoke sObj 'GetConstantAttributes))

                          (vla-put-Height att *hdef*)

                          (if (eq :vlax-false (vla-get-MTextAttribute att))
                            (vla-put-ScaleFactor att *twid*)
                            (vla-put-TextString att (strcat "{\\W" (vl-princ-to-string *twid*) ";"
                                                            (vla-get-TextString att) "}")))))
                      (vla-delete ss)))

                  (vlax-for sub (itemp (vla-get-Blocks *doc) (GetName obj))

                    (cond (  (vl-position (vla-get-ObjectName sub) '("AcDbText" "AcDbAttributeDefinition"))

                             (vla-put-Height sub *hdef*)
                             (vla-put-ScaleFactor sub *twid*))

                          (  (eq "AcDbMText" (vla-get-ObjectName sub))

                             (vla-put-Height sub *hdef*)
                             (vla-put-TextString sub (strcat "{\\W" (vl-princ-to-string *twid*) ";"
                                                             (vla-get-TextString sub) "}")))))

                  (setq uFlag (vla-EndUndomark *doc))
                  (vla-Regen *doc AcActiveViewport))

                (princ "\n** Object Must be a Block **"))))))
 (princ))      

 

Untested yet... but it's gotta be another great routine... how could you do it so fast?

 

I can´t imagine your brain at the top... numbers and stuff floating all around... I am the autocad solution guy in my office, and I have used some of your lisps... I must consider start paying for it

 

But well, I haven´t even created my paypal account yet... I think I'll pay when I decide to start with paypal....

Link to comment
Share on other sites

Untested yet... but it's gotta be another great routine... how could you do it so fast?

 

I can´t imagine your brain at the top... numbers and stuff floating all around... I am the autocad solution guy in my office, and I have used some of your lisps... I must consider start paying for it

 

But well, I haven´t even created my paypal account yet... I think I'll pay when I decide to start with paypal....

 

Its just as fast as I can type... I know exactly the process that I want to use, and what to use etc. I use some code blocks, like the error handler, to save typing it over and over... but really its just practice. :)

 

There's no request for payment for my LISPs... I write them for enjoyment (as do most of the members on here), but of course, we all glady welcome donations :)

Link to comment
Share on other sites

... I must consider start paying for it

 

But well, I haven´t even created my paypal account yet... I think I'll pay when I decide to start with paypal....

 

Donate to the forum. Without it, none of this would be possible.

Link to comment
Share on other sites

  • 4 months later...

Hello Lee Mac,

is it possible to make this work for a selected amount of blocks ? If yes, that would great, cause it´s what I´m searching for a long time !

 

Thanks

geonor

Link to comment
Share on other sites

I haven't looked at it in a while, but I understand that the current code will alter all references of the selected block - would you be looking to select multiple distinct blocks?

Link to comment
Share on other sites

Thanks for your reply.

The problem is, that the data has be exported from a GIS into DXF. The name of the blocks are based on the class of objects in GIS and the unique handle of the object. What means, there are blocks all of the same kind (e.g. sewer manhole) but with different blocknames. It´s like having 1000 copies (each with different block/reference-names) of the same reference. For all of those I would like to change the width/height of all included text. So what I´ve been seaching for was a procedure, that´s allowing to modify all text in a block for a number of selected blocks.

Link to comment
Share on other sites

Hi, try this:

 

(defun c:RedefineBlockText ( / *error* doc blocks GetName ss undo )
 (vl-load-com)
 ;; © Lee Mac 2010

 (defun *error* ( msg )
   (and undo (vla-EndUndoMark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )

 (setq doc    (vla-get-ActiveDocument (vlax-get-acad-object))
       blocks (vla-get-Blocks doc))

 (setq GetName
   (lambda ( obj )
     (if (vlax-property-available-p obj 'EffectiveName)
       (vla-get-EffectiveName obj)
       (vla-get-Name obj)
     )
   )
 )

 (mapcar '(lambda ( sym val ) (or (boundp sym) (set sym val))) '(*hdef* *twid*) '(1. 1.))

 (if (setq ss (ssget "_:L" '((0 . "INSERT"))))
   (
     (lambda ( i / e o n done atts sub )
       (initget 6)
       (setq *hdef* (cond ( (getdist "\nSpecify New Text Height: "  ) ) ( *hdef* )))
       
       (initget 6)
       (setq *twid* (cond ( (getdist "\nSpecify Text Width Factor: ") ) ( *twid* )))
       
       (setq undo (not (vla-StartUndoMark doc)))
       
       (while (setq e (ssname ss (setq i (1+ i))))
         (setq o (vlax-ename->vla-object e))

         (if (not (vl-position (setq n (GetName o)) done))
           (progn

             (if (setq atts (ssget "_X" (list (cons 0 "INSERT") (cons 2 n) (cons 66 1))))
               (
                 (lambda ( j / f p att )
                   
                   (while (setq f (ssname atts (setq j (1+ j))))
                     (setq p (vlax-ename->vla-object f))

                     (foreach att (append (vlax-invoke p 'GetAttributes)
                                          (vlax-invoke p 'GetConstantAttributes))
                       
                       (vla-put-Height att *hdef*)

                       (if (eq :vlax-false (vla-get-MTextAttribute att))
                         (vla-put-ScaleFactor att *twid*)
                         (vla-put-TextString att
                           (strcat "{\\W" (vl-princ-to-string *twid*) ";" (vla-get-TextString att) "}")
                         )
                       )
                     )
                   )
                 )
                 -1
               )
             )

             (vlax-for sub (LM:Itemp Blocks n)

               (cond
                 ( (vl-position (vla-get-ObjectName sub) '("AcDbText" "AcDbAttributeDefinition"))
                  
                   (vla-put-Height sub *hdef*)
                   (vla-put-ScaleFactor sub *twid*)
                 )
                 ( (eq "AcDbMText" (vla-get-ObjectName sub))
                  
                   (vla-put-Height sub *hdef*)
                   (vla-put-TextString sub
                     (strcat "{\\W" (vl-princ-to-string *twid*) ";" (vla-get-TextString sub) "}")
                   )
                 )
               )
             )
             (setq done (cons n done))
           )
         )
       )

       (setq undo (vla-EndUndoMark doc))
       (vla-Regen doc AcActiveViewport)
     )
     -1
   )
 )

 (princ)
)

;;-----------------------=={ Itemp }==------------------------;;
;;                                                            ;;
;;  Retrieves the item with index 'item' if present in the    ;;
;;  specified collection, else nil                            ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  coll - the VLA Collection Object                          ;;
;;  item - the index of the item to be retrieved              ;;
;;------------------------------------------------------------;;
;;  Returns:  the VLA Object at the specified index, else nil ;;
;;------------------------------------------------------------;;

(defun LM:Itemp ( coll item )
 ;; © Lee Mac 2010
 (if
   (not
     (vl-catch-all-error-p
       (setq item
         (vl-catch-all-apply
           (function vla-item) (list coll item)
         )
       )
     )
   )
   item
 )
)

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...