EvilSi Posted July 15, 2009 Share Posted July 15, 2009 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) Quote Link to comment Share on other sites More sharing options...
Commandobill Posted July 15, 2009 Share Posted July 15, 2009 add as in 1+2=3 or add as in "something" = "something 9.123" ? Quote Link to comment Share on other sites More sharing options...
EvilSi Posted July 15, 2009 Author Share Posted July 15, 2009 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. Quote Link to comment Share on other sites More sharing options...
Commandobill Posted July 15, 2009 Share Posted July 15, 2009 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) ) Quote Link to comment Share on other sites More sharing options...
EvilSi Posted July 15, 2009 Author Share Posted July 15, 2009 Wow - that is incredible! Thank you very much indeed for that - much appreciated Quote Link to comment Share on other sites More sharing options...
Commandobill Posted July 15, 2009 Share Posted July 15, 2009 Not a problem! Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted July 15, 2009 Share Posted July 15, 2009 Bill, just a tip, you don't need the: (vl-remove-if 'listp .. When using (ssget "_X") Quote Link to comment Share on other sites More sharing options...
Commandobill Posted July 15, 2009 Share Posted July 15, 2009 Bill, just a tip, you don't need the: (vl-remove-if 'listp .. When using (ssget "_X") 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 Quote Link to comment Share on other sites More sharing options...
gilsoto13 Posted March 30, 2010 Share Posted March 30, 2010 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! ***|; Quote Link to comment Share on other sites More sharing options...
flopo Posted March 31, 2010 Share Posted March 31, 2010 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! Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted March 31, 2010 Share Posted March 31, 2010 Gilsoto, Perhaps look at this thread: http://www.cadtutor.net/forum/showthread.php?t=45679 Quote Link to comment Share on other sites More sharing options...
gilsoto13 Posted March 31, 2010 Share Posted March 31, 2010 You know what.. nevermind... I already found what I need.... i've seen this thread before, but now I remember it... It works for me too.. http://www.cadtutor.org/forum/showthread.php?t=41072 ------------------And you got the answer before... Quote Link to comment Share on other sites More sharing options...
gilsoto13 Posted March 31, 2010 Share Posted March 31, 2010 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? Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted March 31, 2010 Share Posted March 31, 2010 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)) Quote Link to comment Share on other sites More sharing options...
gilsoto13 Posted March 31, 2010 Share Posted March 31, 2010 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 Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted April 1, 2010 Share Posted April 1, 2010 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. Quote Link to comment Share on other sites More sharing options...
gilsoto13 Posted April 3, 2010 Share Posted April 3, 2010 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) Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted April 4, 2010 Share Posted April 4, 2010 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? Quote Link to comment Share on other sites More sharing options...
gilsoto13 Posted April 4, 2010 Share Posted April 4, 2010 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... Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted April 4, 2010 Share Posted April 4, 2010 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. Quote Link to comment Share on other sites More sharing options...
Recommended Posts
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.