Jump to content

Lisp for adding number to multiple text entities?


EvilSi

Recommended Posts

Hello,

 

This might be a little tricky, but does anybody know of a lisp routine that can add a certain number to multiple dtext/mtext entities?

 

For example, I have a topographical survey in dwg format, I do not have the original survey data. I need to adjust the levels to a new datum. I therefore need to add 9.123 to all of the text values.

 

I would be very grateful for any assistance - I'm always telling all my CAD friends how great this site iso:)

 

Thanks!

 

(I am currently using vanilla ACAD 2006)

Link to comment
Share on other sites

  • Replies 30
  • Created
  • Last Reply

Top Posters In This Topic

  • gilsoto13

    7

  • Lee Mac

    6

  • Commandobill

    4

  • EvilSi

    3

Top Posters In This Topic

Posted Images

Ah sorry, I mean I have a set of numbers, say 6.000, 5.900 etc. and I want to add say 1.500 to each and every one of them, so in this instance I would be left with 7.500 and 7.400.

 

I want a lisp that edits the number by adding x amount to it.

Link to comment
Share on other sites

like this?

(defun c:addn ( / ss)
 (vl-load-com)
 (if (and (setq ss (ssget "X" (list (cons 0 "*text"))))
      (setq amt (getreal "\nPlease type the amount you would like to add: ")))
   (progn
     (mapcar '(lambda (z) (vla-put-textstring z (rtos (+ (atof (vla-get-textstring z)) amt) 2 3)))
         (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
     )
   )
 (princ)
 )

Link to comment
Share on other sites

Bill, just a tip, you don't need the:

 

(vl-remove-if 'listp ..

When using

 

(ssget "_X")

:thumbsup:

 

Yeah i know. I didnt know if he was going to select them or have it automated so i threw that in there for good measure. Thanks though :D

Link to comment
Share on other sites

  • 8 months later...

Hey, Lee... I tried to modify another lisp to increment text and mtext with a specific value... but I get the same error in this one and in the one I modified...

 

when I select Mtext with text strings (not just numbers) the specified increment replaces the whole mtext, so I does not work as one would wish... to increment the numerical text with the specified value... would that be possible?

 

;;http://www.autolisp.com/forum/showthread.php?t=347
(defun c:sum ()
(setq meu-ss(ssget '((0 . "TEXT,MTEXT"))))
 (setq value (getdist "\nValue to sum to numbers: "))
;
(setq cntr 0)
(while (< cntr (sslength meu-ss))
;
(setq en(ssname meu-ss cntr))
;
(setq enlist(entget en))
(setq s-tex(cdr(assoc 1 enlist)))
(setq n-tex(atof s-tex))
(setq nf-tex (+ value n-tex))
(setq nft-tex(rtos nf-tex 2 2))
(setq enlist(subst (cons 1 nft-tex)(assoc 1 enlist) enlist))
(entmod enlist)
;
(setq cntr(+ cntr 1))
;
)
)

 

and by the way... I have been taking small steps with selection sets.. but at this moment I can say I am only taking other existing codes to do a little more things with commands and selections.... I made something else today...

 

I converted a routine to Insert points at center of each selected circles.. into a routine to insert a block at every selected circle... and then into a routine to select polylines, lwpolylines and circles and do wipeouts with them... .. no error handlers nor any of that stuff.. but It works.

;BINCIRCLE.lsp 01/01/97 Jeff Foster
;
;OBJECTIVE***
;The purpose of this routine is to allow the user to enter
;a text item and place that same text in the center of a selection
;of circles
;
;TO RUN***
;At the command line, type (load "c:/lispdir/txtncirc")
;where c:/ is the drive where TXTNCIRC.lsp is contained
;where lispdir/ is the directory where TXTNCIRC.lsp is contained
;
;
;If you find this routine to be helpful, please give consideration
;to making a cash contribution of $10.00 to:
;         Jeff Foster
(DEFUN C:BINCIRCLE (/ SS EN ED AS)
 (SETQ DM (GETVAR "DIMSCALE"))
 (PRINC "SELECT CIRCLES TO PUT TEXT INTO")
 (SETQ SS (SSGET))
 (WHILE (> (SSLENGTH SS) 0)
   (PROGN
   (SETQ EN (SSNAME SS 0))
   (SETQ ED (ENTGET EN))
   (SETQ AS (CDR (ASSOC '0 ED)))
   (SETQ START (CDR (ASSOC '10 ED)))
   (IF (= AS "CIRCLE")
   (COMMAND "INSERT" "COLUMN ROW BUBBLE" START DM DM "0" "")
   )
   (PRIN1)
   (SSDEL EN SS)
 ))
 (PRIN1)
)

 

;; C2W3.lsp BY Paulo Gil Soto - March 2010
;; draws a wipeout made of a polygon of 40 sides over each selected circle.
;; and will replace selected closed polylines and lwpolylines with a wipeout
;; Selected circles are deleted
;; Most of the code taken from  Jeff Foster --01/01/97
;;
;;
(DEFUN C:C2W3 (/ SS EN ED AS)
(COMMAND "undo" "begin")  ;beginning of undo group 
 (AND (SETQ ss (SSGET "_:L" '((0 . "CIRCLE,*POLYLINE"))))
      (FOREACH x (VL-REMOVE-IF 'LISTP (MAPCAR 'CADR (SSNAMEX ss)))
 (COND
   ((EQ "CIRCLE" (CDR (ASSOC 0 (SETQ elist (ENTGET x)))))
 (WHILE (> (SSLENGTH SS) 0) 
   (PROGN 
   (SETQ EN (SSNAME SS 0)) 
   (SETQ ED (ENTGET EN)) 
   (SETQ AS (CDR (ASSOC '0 ED))) 
   (SETQ START (CDR (ASSOC '10 ED))) 
   (SETQ RAD (CDR (ASSOC '40 ED))) 
   (IF (= AS "CIRCLE") 
   (COMMAND "POLYGON" "40" START "I" RAD "WIPEOUT" "P" "L" "Y" "ERASE" EN "") 
   ) 
   (IF (= AS "LWPOLYLINE") 
   (COMMAND "WIPEOUT" "P" EN "Y") 
   ) 
   (IF (= AS "POLYLINE") 
   (COMMAND "WIPEOUT" "P" EN "Y") 
   ) 
   (PRIN1) 
   (SSDEL EN SS) 
 )) 
         (ENTMOD elist)
   )
    
   (T T)
 ) ;_ cond
      ) ;_ foreach
 ) ;_ and

 (COMMAND "undo" "end")  ;end of undo group

) ;_ defun

;|«Visual LISP© Format Options»
(80 2 40 2 nil "end of " 60 9 2 0 0 T T T T)
;*** DO NOT add text below the comment! ***|;

Link to comment
Share on other sites

Hello everybody,

If i have a block with an attribute, ... B1, is it possible to add a number to this attribute, to be B2? Thanks!

Link to comment
Share on other sites

Yours It's a great routine..

 

Nevertheless, I got a question. After using it, it rounds to 1 decimal... how can I change it to 3 decimals for resulting mtexts?

Link to comment
Share on other sites

For 3 d.p

 

(defun c:Text_Inc (/ *error* ParseNumbers uFlag ss)
 (vl-load-com)
 ;; Lee Mac  ~  10.03.10

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

 (defun ParseNumbers (str / lst Num Aph x rtn)
   ;; Lee Mac  ~  20.09.09
   (setq lst (vl-string->list str) Num "" Aph "")
   
   (while (setq x (car lst))
     (setq lst (cdr lst))
     
     (cond (  (and (/= "" Num) (= 46 x))
              (setq Num (strcat Num (chr x))))
           
           (  (< 47 x 58)
              (setq Num (strcat Num (chr x))
                    rtn (cons Aph rtn) Aph ""))
           
           (t (setq Aph (strcat Aph (chr x))
                    rtn (cons (read Num) rtn) Num ""))))
   
   (vl-remove nil
     (vl-remove "" (reverse (cons Aph (cons (read Num) rtn))))))
 

 (setq *inc* (cond (*inc*) (1.0)))
 (setq *inc* (cond ((getreal (strcat "\nSpecify Increment <"
                                     (vl-princ-to-string *inc*) "> : ")))
                   (*inc*)))

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

 (setvar 'NOMUTT 1)
 (princ "\nSelect Text to Increment <All> : ")
 (if (or (ssget "_:L" '((0 . "MTEXT,TEXT")))
         (ssget "_X"  '((0 . "MTEXT,TEXT"))))
   (progn
     (setq uFlag (not (vla-StartUndoMark *doc)))
     
     (vlax-for obj (setq ss (vla-get-ActiveSelectionSet *doc))
       (vla-put-TextString obj
         (apply (function strcat)
                (mapcar
                  (function
                    (lambda (x) (if (vl-position (type x) '(INT REAL))
                                  (rtos (+ x *inc*) (getvar 'LUNITS) 3) x)))

                  (ParseNumbers (vla-get-TextString obj))))))

     (vla-delete ss)
     (setq uFlag (vla-EndUndoMark *doc))))  

 (setvar 'NOMUTT 0)
 (princ))

Link to comment
Share on other sites

For 3 d.p

 

(defun c:Text_Inc (/ *error* ParseNumbers uFlag ss)
 (vl-load-com)
 ;; Lee Mac  ~  10.03.10

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


 (defun ParseNumbers (str / lst Num Aph x rtn)
   ;; Lee Mac  ~  20.09.09
   (setq lst (vl-string->list str) Num "" Aph "")

   (while (setq x (car lst))
     (setq lst (cdr lst))

     (cond (  (and (/= "" Num) (= 46 x))
              (setq Num (strcat Num (chr x))))

           (  (< 47 x 58)
              (setq Num (strcat Num (chr x))
                    rtn (cons Aph rtn) Aph ""))

           (t (setq Aph (strcat Aph (chr x))
                    rtn (cons (read Num) rtn) Num ""))))

   (vl-remove nil
     (vl-remove "" (reverse (cons Aph (cons (read Num) rtn))))))


 (setq *inc* (cond (*inc*) (1.0)))
 (setq *inc* (cond ((getreal (strcat "\nSpecify Increment <"
                                     (vl-princ-to-string *inc*) "> : ")))
                   (*inc*)))

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

 (setvar 'NOMUTT 1)
 (princ "\nSelect Text to Increment <All> : ")
 (if (or (ssget "_:L" '((0 . "MTEXT,TEXT")))
         (ssget "_X"  '((0 . "MTEXT,TEXT"))))
   (progn
     (setq uFlag (not (vla-StartUndoMark *doc)))

     (vlax-for obj (setq ss (vla-get-ActiveSelectionSet *doc))
       (vla-put-TextString obj
         (apply (function strcat)
                (mapcar
                  (function
                    (lambda (x) (if (vl-position (type x) '(INT REAL))
                                  (rtos (+ x *inc*) (getvar 'LUNITS) 3) x)))

                  (ParseNumbers (vla-get-TextString obj))))))

     (vla-delete ss)
     (setq uFlag (vla-EndUndoMark *doc))))  

 (setvar 'NOMUTT 0)
 (princ))

 

 

I think the routine should store the NOMUTT variable and reset it to its original value instead of change it to 0 when using the routine..

 

 

But anyway the decimal places thing didn´t work.. I made some research... but I can´t find the answer yet...

 

I am not using CAB's routine cause that's for a different purpose... but yours is what I was looking for...

 

also the routine in the thread I mentioned didn´t work after modifying it... so your routine is the only one that works for the case i am running here... but would be perfect If I could get the 3 decimal places...

 

attached a sample dwg to test if necessary.

A SAMPLE.dwg

Link to comment
Share on other sites

I think the routine should store the NOMUTT variable and reset it to its original value instead of change it to 0 when using the routine..

 

With NOMUTT, I don't think there is any harm in setting it to 0, I doubt any user has it always set to 1.

 

But anyway the decimal places thing didn´t work.. I made some research... but I can´t find the answer yet...

 

All works for me, its only in the rtos conversion.

Link to comment
Share on other sites

wEell... I was updating my help files and found I already had this one from years ago.... and actually works as I expect for numbers and text as objects... I just didn´t remember....

; Increments the first postive number in a TEXT string by the given increment
;;; ==========================================================================
;;;  Program: INC.LSP  ver 1.22
;;;                                                                         
;;;  Purpose: Increments the first postive number in a TEXT string by the given increment
;;;
;;;  Syntax:  INC
;;;
;;;           Resolutions                                                   
;;;           P.O. Box 1265                                                 
;;;           Sumner WA 98390-0250                                          
;;;           206-845-2200                                                  
;;;
;;;  Date:             5/10/95
;;;
;;;  Revisions:  ver 1.1  8/7/95    Added support for REALs
;;;
;;;  Revisions:  ver 1.2  12/12/95  Added support for Stations
;;;
;;;  Revisions:  ver 1.21 12/14/95  Fixed problem with decimal places
;;;
;;;  Revisions:  ver 1.22 1/16/96   Fixed problem with decimal places when
;;;                                 number is preceeded by alpha characters.
;;; ==========================================================================
(defun C:INC (/ ; Functions & Variables
   ; Functions
           val put r_fill getdp at
   ; Variables
           ss inc i l e j k ascii_nr string newstring nr count dp1 dp
           OldStation dp_pos end_pos
   )
;=============================
; Entity assoc list utilities
;-----------------------------
(defun val (nr e) (cdr (assoc nr e)))
(defun put (x nr e)(subst (cons nr x) (assoc nr e) e))
;;; ==========================================================================
;;; Function: AT
;;; Purpose : Returns the position of the first occurance of a string
;;;           or NIL if not found
;;; Params  : string        String to search
;;;               char            String to locate
;;;
;;; Uses    : 
;;; --------------------------------------------------------------------------
   (defun at (string char / i len clen)
       (if string
           (progn
               (setq i 1 len (strlen string) clen (strlen char))
               (while (and (<= i len) (/= (substr string i clen) char))
                   (setq i (1+ i))
               )
               (if (> i len)
                   (setq i nil)
               )
               (eval i)
           )
       )
   )
;;; ==========================================================================
;;; Function: R_FILL <string> <len>
;;; Purpose : Returns a string filled with spaces on the right
;;;
;;; Params  : string        String to fill
;;;           len             String length
;;;
;;; --------------------------------------------------------------------------
(defun r_fill (s len / space i)
  (setq space "" i (- len (strlen s)))
  (if (> i 0)
      (substr (strcat s (repeat i (setq space (strcat space " ")))) 1 len)
      s
  )
)
;; Return number of decimal places of a REAL
(defun getdp (nr / n)
   (setq n 0 nr (abs nr))
   (while (null (equal (fix (+ nr 0.5)) nr 0.000001))
       (setq n (1+ n))
       (setq nr (* nr 10))
   )
   n
)
;;; ==========================================================================
   ;-- Start C:TEXTINC
   (setvar "CMDECHO" 0)
   (princ "\nSelect TEXT containing NUMBERS to increment.")
   (if (and
           (setq ss (ssget '((0 . "*TEXT"))))
           (setq inc (getreal "\nIncrement: "))
           (/= inc 0)
       )
       (progn
           (setq i 0 l (sslength ss) count 0)
           (while (< i l)
               (setq e (entget (ssname ss i)))
               (setq string (val 1 e))
               ;; --- Check for an number ---
               (if (and 
                       (wcmatch string "*[0-9]*")       ; Find an INT
;                        (wcmatch string "~*#.#*")        ; No REALs
                       (wcmatch string "~*%%d*")        ; No BEARINGS
                   )
                   (progn
                       (setq count (1+ count))
                       (setq j 1 k (strlen string))
                       (if (wcmatch string "*#+##*")  ; Check for Station
                           (setq
                               OldStation string
                               j (at string "+")
                               string (strcat
                                       (substr string 1 (1- j))
                                       (substr string (1+ j))
                                   )
                               j 1
                               k (strlen string)
                           )
                       )
                       ;; --- Step though the string looking
                       ;; --- for the first int ---
                       (while (<= j k)
                           (setq ascii_nr (ascii (substr string j 1)))
                           (if (and (>= ascii_nr 48)(<= ascii_nr 57))
                               (progn
                                   (setq end_pos j)
                                   (while (or (= ascii_nr 46)(and (>= ascii_nr 48)(<= ascii_nr 57)))
                                       (setq
                                           end_pos (1+ end_pos)
                                           ascii_nr (ascii (substr string end_pos 1))
                                       )
                                   )
                                   (setq
                                       dp_pos (at (substr string j) ".")
                                       nr    (atof (substr string j))
                                       dp1 (if dp_pos (- end_pos dp_pos j) 0)
                                       dp (max dp1 (getdp inc))
                                       nr (+ nr inc)
                                       newstring (strcat 
                                           (substr string 1 (1- j))
                                           (rtos nr 2 dp)
                                           (substr string end_pos)
                                       )
                                       j k     ;; Now exit
                                   )
                               )
                           )
                           (setq j (1+ j))
                       )
                       ;; If station then insert the "+"
                       (if OldStation
                           (progn
                               (setq string Oldstation)
                               (if (setq j (at newstring "."))
                                   (setq j (- j 3))
                                   (setq j (- (strlen newstring) 2))
                               )
                               (setq newstring
                                   (strcat (substr newstring 1 j) "+"
                                           (substr newstring (1+ j))
                                   )
                               )
                           )
                       )
                       ;; --- Echo changes to screen ---
                       (princ (strcat "\n" (r_fill string 12) "-->  " newstring))
                       ;; --- Update the TEXT entity ---
                       (entmod (put newstring 1 e))
                   )
                   (princ (strcat "\nNo Numeric value: " string))
               )
               (setq i (1+ i))
           )
           (princ (strcat "\n" (itoa count) " TEXT number\(s\) incremented."))
       )
       (princ "\nTEXTINC cancelled.")
   )
   (princ)
)
(princ "\nTEXTINC.LSP v1.22")
(princ)

Link to comment
Share on other sites

But anyway the decimal places thing didn´t work.. I made some research... but I can´t find the answer yet...

 

Does it error? What do you get?

Link to comment
Share on other sites

Weird... I remember getting only 1 decimal place in the results at the office... in acad 2009, today in autocad 2008 everything was ok... so... I 'll let you know if there's something wrong tomorrow... but I don't think I'll need extra work cause the other option I found in my files... everything is ok...

BEFORE.JPG

after.JPG

Link to comment
Share on other sites

It could be that you didn't reload the new LISP before testing - as I say, it was only in the number -> string conversion - it isn't a particularly complex LISP for things to go wrong. :)

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...