Update numbers in a drawing by constant

Does anyone know of a Lisp Routine that will help me with Survey Spot
Levels. I have a measured survey of a plot of land with a hundred or so
levels that need to be changed by a constant amount. Any help much
appreciated.

ASmith

 

Not enough info (sorry, only a lisper) to be able
to help. Are these spot levels plain text/mtext or
attributes in a block. Can you post a sample
drawing?

Noah

 

here is the code to do what you want.
Its a little gem of mine that I owe back to these newsgroups for all the help I get.
It uses some decent string handling mechanisms so its a good one to steal subroutines from for other uses.
It affects all text, mtext, or block attributes selected.
It even allows you to force decimal places which is pretty slick.
The best thing is that it preserves prefixes and suffixes around the numbers. I can't live without it.

Throw all this code in a lisp file and load it.
Run with "ADJUST-NUMS"


(DEFUN C:ADJUST-NUMS ( / SS INDEX ITEM FULL-STR NEW-TXT EL DIMZIN TMP
ASELECTION GROUPS)
;GROUPS
(SETQ ASELECTION (vla-get-Selection (vla-get-Preferences (vlax-get-acad-object))))
(SETQ GROUPS (vla-get-PickGroup ASELECTION))
(vla-put-PickGroup ASELECTION :vlax-false)
;GET OBJECT
(PRINC "\nSelect items to modify: ")
(SETQ SS (SSGET))
(IF (NOT ADJ-VAL)(SETQ ADJ-VAL 1.0))
(SETQ TMP (GETREAL (STRCAT "\nEnter Amount to add (- for subtract)<" (RTOS ADJ-VAL 2 2) ">: ")))
(IF TMP (SETQ ADJ-VAL TMP))
(SETQ FORCE-DEC (GETINT "\nEnter decimal places, or return to use existing: "))
(SETQ INDEX 0)
(SETQ DIMZIN (GETVAR "DIMZIN"))
(SETVAR "DIMZIN" 0)
(REPEAT (SSLENGTH SS)
(SETQ ITEM (SSNAME SS INDEX))
(COND
;-----DEAL WITH TEXT-------
((= (CDR (ASSOC 0 (ENTGET ITEM))) "TEXT")
(SETQ FULL-STR (CDR (ASSOC 1 (ENTGET ITEM))))
(IF (SETQ NEW-TXT (MOD-NUM-IN-STR FULL-STR ADJ-VAL FORCE-DEC))
(PROGN
;SUB IN NEW VALUE
(ENTMOD (SUBST (CONS 1 NEW-TXT)(ASSOC 1 (ENTGET ITEM)) (ENTGET ITEM)))
(ENTUPD ITEM)
)
)
)
;-----DEAL WITH MTEXT-------
((= (CDR (ASSOC 0 (ENTGET ITEM))) "MTEXT")
(SETQ FULL-STR (CDR (ASSOC 1 (ENTGET ITEM))))
;SPLIT OUT 1ST PORTION OF MTEXT WHICH MAY BE \A1;
;ASSUME ; IS DELIMITER
(SETQ SPLIT-LIST (STRINGSPLIT FULL-STR ";"))
;REARRANGE IF NO ;
(IF (= (CADR SPLIT-LIST) NIL)
(SETQ SPLIT-LIST (LIST "" (CAR SPLIT-LIST)))
)
(IF (SETQ NEW-TXT (MOD-NUM-IN-STR (CADR SPLIT-LIST) ADJ-VAL FORCE-DEC))
(PROGN
;SUB IN NEW VALUE
(IF (/= (CAR SPLIT-LIST) "")
(SETQ NEW-TXT (STRCAT (CAR SPLIT-LIST) ";" NEW-TXT))
)
(ENTMOD (SUBST (CONS 1 NEW-TXT)(ASSOC 1 (ENTGET ITEM)) (ENTGET ITEM)))
(ENTUPD ITEM)
)
)
)
;-----DEAL WITH ATTRIBUTES-------
((AND (= (CDR (ASSOC 0 (ENTGET ITEM))) "INSERT") ;A BLOCK
(= (CDR (ASSOC 66 (ENTGET ITEM))) 1) ;HAS ATTRIBUTES
(NOT (ASSOC 1 (TBLSEARCH "BLOCK" (CDR (ASSOC 2 (ENTGET ITEM)))))) ;NO XREFS
)
;LOOP THROUGH ATTRIBUTES AND REPLACE AS NEEDED
(SETQ ITEMT ITEM)
(WHILE (= "ATTRIB" (CDR (ASSOC 0 (SETQ EL (ENTGET (SETQ ITEMT (ENTNEXT ITEMT)))))))
(SETQ FULL-STR (CDR (ASSOC 1 EL)))
(IF (SETQ NEW-TXT (MOD-NUM-IN-STR FULL-STR ADJ-VAL FORCE-DEC))
(PROGN
;SUB IN NEW VALUE
(ENTMOD (SUBST (CONS 1 NEW-TXT)(ASSOC 1 EL) EL))
)
)
)
(ENTUPD ITEM)
)
)
(SETQ INDEX (+ 1 INDEX))
)
(vla-put-PickGroup ASELECTION GROUPS)
(SETQ ASELECTION NIL)
(SETVAR "DIMZIN" DIMZIN)
)

;MODIFY NUMBER VALUE IN A STRING

;(MOD-NUM-IN-STR "AAA123.45WWW" 1.0)
(DEFUN MOD-NUM-IN-STR (IN-STRING ADJ-VAL FORCE-DEC
/ NUM-STR-LST NUM-STR NUM-POS SPLIT-LST DEC-PLACES
NEW-VAL NEW-STR NEW-TXT)
(IF (SETQ NUM-STR-LST (EXTRACT_NUM_STR IN-STRING))
(PROGN
(SETQ NUM-STR (CADR NUM-STR-LST)
NUM-POS (CAR NUM-STR-LST)
)
;FIND DEC PLACES
(IF (NOT FORCE-DEC)
(IF (WCMATCH NUM-STR "*`.*")
(PROGN
(SETQ SPLIT-LST (STRINGSPLIT NUM-STR "."))
(SETQ DEC-PLACES (STRLEN (CADR SPLIT-LST)))
)
(SETQ DEC-PLACES 0)
)
(SETQ DEC-PLACES FORCE-DEC)
)
;FIGURE NEW NUMERIC VALUE
(SETQ NEW-VAL (ROUND (+ ADJ-VAL (ATOF (CT-REMOVE-CHARS NUM-STR))) DEC-PLACES))
;FIGURE NEW STRING
;NOW DEAL WITH STATIONS
(IF (WCMATCH NUM-STR "*+*")
(SETQ NEW-STR (CREATE-STA-STRING NEW-VAL DEC-PLACES "1"))
(SETQ NEW-STR (RTOS NEW-VAL 2 DEC-PLACES))
)
;TACK BACK TOGETHER
(SETQ NEW-TXT (STRCAT (SUBSTR IN-STRING 1 (- NUM-POS 1))
NEW-STR
(SUBSTR IN-STRING
(+ NUM-POS (STRLEN NUM-STR))
(STRLEN IN-STRING)
)
)
)
)
NIL
)
)

;;;---------FIND NUMBER IN A STRING ----------------
;FINDS THE 1ST NUMBER WITHIN A STRING, ALLOWS COMMAS AND +'S

;SUPPLY:
;STRING String to find number in
;RETURN:
;LIST OF Number value, START POSITION if found, NIL if not found

;(EXTRACT_NUM_STR "AAA123AAA")
(DEFUN EXTRACT_NUM_STR (STRING
/ DONE TEXT-POS DEC-FND RETURN_STRING
CUR-CHAR START
)
(SETQ DONE 0
TEXT-POS 1
DEC-FND 0
RETURN_STRING ""
)
(WHILE (<= TEXT-POS (STRLEN STRING))
(SETQ CUR-CHAR (SUBSTR STRING TEXT-POS 1))
(COND
((AND ;FIRST CHARACTER
(= RETURN_STRING "")
(= DONE 0)
(WCMATCH CUR-CHAR "#")
)
(SETQ RETURN_STRING (STRCAT RETURN_STRING CUR-CHAR))
(SETQ START TEXT-POS)
)
((AND ;DECIMAL ALREADY FOUND
(= DEC-FND 1)
(= DONE 0)
(WCMATCH CUR-CHAR "#")
)
(SETQ RETURN_STRING (STRCAT RETURN_STRING CUR-CHAR))
)
((AND ;PAST 1ST AND DECIMAL NOT FOUND
(/= RETURN_STRING "")
(= DEC-FND 0)
(= DONE 0)
(WCMATCH CUR-CHAR "#,`.,`,,+,")
)
(SETQ RETURN_STRING (STRCAT RETURN_STRING CUR-CHAR))
(IF (EQUAL CUR-CHAR ".")
(SETQ DEC-FND 1)
)
)
((OR
(AND
(= DEC-FND 1)
(NOT (WCMATCH CUR-CHAR "#"))
)
(AND
(/= RETURN_STRING "")
(NOT (WCMATCH CUR-CHAR "#,`.,`,,+"))
)
)
(SETQ DONE 1)
)
)
(SETQ TEXT-POS (+ TEXT-POS 1))
)
;DEAL WITH STATION
(IF (/= RETURN_STRING "")
(SETQ FINAL_STRING (LIST START
(STRINGREPL-ALL RETURN_STRING "," "")
;(IF (WCMATCH RETURN_STRING "*+*") 1 0)
)
)
(SETQ FINAL_STRING NIL)
)
)

;------STRINGREPL-ALL.LSP------

;SUPPLY:
;SRC source string
;SRCH string to find
;SREP replacement string
;RETURN:
;STRING WITH REPLACED SUBSTRING
;
(defun STRINGREPL-ALL (SRC SRCH SREP)
(while (/= SRC (setq SRC (STRINGREPL SRC SRCH SREP))))
SRC
)

;------STRINGREPL.LSP------

;SUPPLY:
;SRC source string
;SRCH string to find
;SREP replacement string
;RETURN:
;STRING WITH REPLACED SUBSTRING

(defun STRINGREPL (SRC SRCH SREP / TMP)
(setq TMP (STRINGSPLIT SRC SRCH))
(if (not (null (cadr TMP))) (strcat (car TMP) SREP (cadr TMP)) SRC)
)

;------STRINGSPLIT.LSP-------

;SUPPLY:
;SRC String to search
;SRCH String pattern to find
;RETURN:
;LIST OF CHARS BEFORE AND AFTER SRCH STRING
;(STRINGSPLIT "ASD;2134" ";")

(defun STRINGSPLIT (SRC SRCH / CNT RET)
(setq CNT 1)
(while (<= CNT (strlen SRC))
(if
(= (substr SRC CNT (strlen SRCH)) SRCH)
(setq RET (list
(substr SRC 1 (1- CNT))
(substr SRC (+ CNT (strlen SRCH))))
CNT (1+ (strlen SRC)))
(setq CNT (1+ CNT))))
(if (null RET) (list SRC nil) RET)
)

;------ROUND.LSP-------

;SUPPLY:
;NUMB Starting Number
;DEC Decimal Places desired
;RETURN:
;Rounded number

(DEFUN ROUND (NUMB DEC / RM)
(SETQ DEC (FLOAT DEC))
(COND
((>= DEC 0)
(SETQ INT (FIX (* NUMB (EXPT 10 DEC)))
RM (REM (* NUMB (EXPT 10 DEC)) 1)
)
(IF (>= RM 0.5)
(SETQ INT (+ 1 INT))
)
(SETQ INT (/ (* 1 INT) (EXPT 10 DEC)))
)
((< DEC 0)
(SETQ DEC (ABS DEC)
INT (FIX (/ NUMB (EXPT 10 DEC)))
RM (REM (/ NUMB (EXPT 10 DEC)) 1)
)
(IF (> RM 0.5)
(SETQ INT (+ 1 INT))
)
(SETQ INT (* INT (EXPT 10 DEC)))
)
)
)

;------CREATE-STA-STRING.LSP------

;SUPPLY:
;STA-VALUE REAL OF STATION
;STA-PREC DECIMAL PLACES TO SHOW
;AS-IMPERIAL FLAG FOR IMPERIAL (1) OR METRIC (0)

;RETURN:
;STA-STRING STRING WITH REQUESTED PROPERTIES
;(CREATE-STA-STRING 1000.0 4 "1")

(DEFUN CREATE-STA-STRING (STA-VALUE STA-PREC AS-IMPERIAL
/ STA-STRING SL)
;;; (SETQ STA-VALUE (GET-GVAR "START-STA" "CT-STA-VARS")
;;; STA-PREC 4
;;; AS-IMPERIAL "1"
;;; STA-PREFIX ""
;;; STA-SUFFIX ""
;;; )

(IF (/= STA-VALUE NIL)
(PROGN
(SETQ ORIG-DIMZIN (GETVAR "DIMZIN"))
(SETVAR "DIMZIN" 0)
(SETQ STA-STRING (RTOS STA-VALUE 2 STA-PREC))
(SETQ SL (STRLEN STA-STRING))
(IF (= AS-IMPERIAL "1")
;DO AS IMPERIAL
(PROGN
(IF (/= STA-PREC 0)
(SETQ DEC-SPACE 0)
(SETQ DEC-SPACE 1)
)
(COND
((= SL (+ (- 2 DEC-SPACE) STA-PREC)) (SETQ STA-STRING (STRCAT "0+0" STA-STRING)))
((= SL (+ (- 3 DEC-SPACE) STA-PREC)) (SETQ STA-STRING (STRCAT "0+" STA-STRING)))
((> SL (+ (- 3 DEC-SPACE) STA-PREC))
(SETQ STA-STRING (STRCAT (SUBSTR STA-STRING 1 (- SL (+ (- 3 DEC-SPACE) STA-PREC))) "+"
(SUBSTR STA-STRING (- SL (+ (- 2 DEC-SPACE) STA-PREC)))))
)
)
)
;ELSE DO AS METRIC
(PROGN
(IF (/= STA-PREC 0)
(SETQ DEC-SPACE 0)
(SETQ DEC-SPACE 1)
)
(COND
((= SL (+ (- 2 DEC-SPACE) STA-PREC)) (SETQ STA-STRING (STRCAT "0+00" STA-STRING)))
((= SL (+ (- 3 DEC-SPACE) STA-PREC)) (SETQ STA-STRING (STRCAT "0+0" STA-STRING)))
((= SL (+ (- 4 DEC-SPACE) STA-PREC)) (SETQ STA-STRING (STRCAT "0+" STA-STRING)))
((> SL (+ (- 4 DEC-SPACE) STA-PREC))
(SETQ STA-STRING (STRCAT (SUBSTR STA-STRING 1 (- SL (+ (- 4 DEC-SPACE) STA-PREC))) "+"
(SUBSTR STA-STRING (- SL (+ (- 3 DEC-SPACE) STA-PREC))))
)
)
)
)
)
(SETVAR "DIMZIN" ORIG-DIMZIN)
STA-STRING
)
)
)

;------CT-REMOVE-CHARS.LSP------

;SUPPLY:
;TEXT STRING TO REMOVE CHARS FROM
;RETURN:
;STRING

(DEFUN CT-REMOVE-CHARS (TEXT / INDEX NEWTEXT)
;REMOVE ALL CHARS NOT NUMBERS
(SETQ INDEX 1
NEWTEXT ""
DEC NIL
)
(REPEAT (STRLEN TEXT)
(COND
((AND
(= (SUBSTR TEXT INDEX 1) ".")
(NOT DEC)
)
(SETQ NEWTEXT (STRCAT NEWTEXT (SUBSTR TEXT INDEX 1))
DEC 1
)
)
((DISTOF (SUBSTR TEXT INDEX 1) 2)
(SETQ NEWTEXT (STRCAT NEWTEXT (SUBSTR TEXT INDEX 1)))
)
)
(SETQ INDEX (+ 1 INDEX))
)
NEWTEXT
)

Thats it, enjoy

"Andrew Smith" <>
|>Does anyone know of a Lisp Routine that will help me with Survey Spot
|>Levels. I have a measured survey of a plot of land with a hundred or so
|>levels that need to be changed by a constant amount. Any help much
|>appreciated.
|>
|>ASmith
|>

James Maeding
Civil Engineer/Programmer

 

wow, I'm suprised no one has commented on that code.
That was a tough routine due to nitty gritty things. THe functions are simple though.
Hope someone takes a second to try it as not too many routines check for all I did in that one.

"Andrew Smith" <>
|>Does anyone know of a Lisp Routine that will help me with Survey Spot
|>Levels. I have a measured survey of a plot of land with a hundred or so
|>levels that need to be changed by a constant amount. Any help much
|>appreciated.
|>
|>ASmith
|>

James Maeding
Civil Engineer/Programmer

 

Thank you James your routine worked like a dream. I am very grateful to you
for your help.
Regards Andrew

 

See, "addl", at, http://www.btlsp2000.com/page9.html.