Elevation Marker LISP Routine - Help Please
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hello Good People,
I have been working on this LISP I have found to suit our purposes.
So far most things I changes have work but for some reason this routine fails at the the most important stage.
If I set the datum to 88 for example and then apply 1000 vertical scale it does not insert the correct height.
And if do it at 100 vertical it doubles!?
I assume it has something to do with insertion point or how the block being made within the LISP.
It would also be good for this LISP to round up to 1 decimal place.
If someone could please help it would be highly appreciated as I simply can't find the issue.
Thanks.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Title : Elevation Marker ;;
;; Purpose : To get Elevation ;;
;; System requirement : Autocad 2007 ;;
;; Command : Dat, Ele & uw ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;-------------------------------------------* error *-----------------------------------------------------
(defun trap1 (errmsg)
(setq *error* temperr)
(setvar "clayer" clay)
(prompt "\nEnter Command UW to make UCS origin to World")
(princ)
) ;defun
;;-----------------------------------sub function to create block---------
(defun elblock ( )
(if (not (tblsearch "BLOCK" "ELBLK"))
(progn
(if (not (tblsearch "STYLE" "Gen-Text"))
(entmake
(list
(cons 0 "STYLE")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbTextStyleTableRecord")
(cons 2 "Gen-Text")
(cons 70 0)
(cons 40 300.0)
(cons 3 "Arial narrow.ttf")
)
)
)
(entmake
(list
(cons 0 "BLOCK")
(cons 8 "0")
(cons 370 0)
(cons 2 "ELBLK")
(cons 70 2)
(cons 4 "Block to Place Trial pit Locations")
(list 10 0.0 0.0 0.0)
)
)
(entmake
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 8 "0")
(cons 370 0)
(cons 90 4)
(cons 70 1)
(list 10 2000.0 2000.0)
(list 10 0.0 0.0)
(list 10 -2000.0 2000.0)
)
)
(entmake
(list
(cons 0 "ATTDEF")
(cons 8 "0")
(cons 370 0)
(cons 7 "Gen-Text")
(list 10 -1000.0 2750.0 0.0)
(list 11 -1000.0 2000.0 0.0)
(cons 40 3000.0)
(cons 1 "±0.000m")
(cons 3 "Elevation")
(cons 2 "EL")
(cons 70 0)
(cons 72 0)
(cons 74 1)
(cons 280 1)
)
)
(entmake
(list
(cons 0 "ENDBLK")
(cons 8 "0")
)
)
;;--- To set block units in metre 70-6
(
(lambda ( lst )
(regapp "ACAD")
(entmod
(append (subst (cons 70 6) (assoc 70 lst) lst)
(list
(list -3
(list "ACAD"
(cons 1000 "DesignCenter Data")
(cons 1002 "{")
(cons 1070 1)
(cons 1070 1)
(cons 1002 "}")
)
)
)
)
)
)
(entget (cdr (assoc 330 (entget (tblobjname "BLOCK" "ELBLK")))))
)
;;;--- To make block annotative
(
(lambda ( lst )
(regapp "ACAD")
(regapp "AcadAnnotative")
(entmod
(append (subst (cons 70 1) (assoc 70 lst) lst)
(list
(list -3
(list "ACAD"
(cons 1000 "DesignCenter Data")
(cons 1002 "{")
(cons 1070 1)
(cons 1070 1)
(cons 1002 "}")
)
(list "AcadAnnotative"
(cons 1000 "AnnotativeData")
(cons 1002 "{")
(cons 1070 1)
(cons 1070 1)
(cons 1002 "}")
)
)
)
)
)
)
(entget (cdr (assoc 330 (entget (tblobjname "BLOCK" "ELBLK")))))
)
)
)
;;;--- to disable allow explod-----
(vl-load-com)
(setq BLOCKS
(vla-get-Blocks
(vla-get-activedocument
(vlax-get-acad-object)
)
)
BLK (vla-Item BLOCKS "ELBLK")
)
(vla-put-explodable (vla-Item BLOCKS "ELBLK") :vlax-false)
;;;--- end to disable allow explod-----
(princ)
)
;;-------------------------------------------Set Datum-----------------------------------------------------
(defun C:edat (/ enum eop esta epga estb epgb)
(command "cmdecho"0)
;;; input x
(setq enum 0)
;;; input y
(if (not esf-ss) (setq esf-ss 0.0)) ; default number
(setq esum (getreal (strcat "\nEnter vertical datum (Elevation) <" (rtos esf-ss 2 3) ">: ")))
(if (not esum) (setq esum esf-ss) (setq esf-ss esum))
;;; set orign point
(setq eop (getpoint "\nPick datum orgin point: "))
(setq esta (car eop))
(setq epga (cadr eop))
(setq estb (- esta enum))
(setq epgb (- epga esum))
(command "ucs" "m" (list estb epgb 0))
(prompt "\nOrigin moved to new loaction - Enter Command ELE to place Marker")
(princ)
) ;defun
;;-------------------------------------------Place Text----------------------------------------------------
(defun C:ELE ()
(if (not esum) (alert "\n Set Vertical DATUM \n Command - EDAT ")(estn1))
) ;defun
(defun estn1 (/ epnt1 ep1y estdy e ele-text ptlist)
(command "cmdecho"0)
(setq clay (getvar "clayer"))
(setq temperr *error*)
(setq *error* trap1)
(if (not (tblsearch "layer" "Elevation Marker")) (command "-LAYER" "N" "Elevation Marker" "C" "7" "Elevation Marker" "LT" "Continuous" "Elevation Marker""LW" "0.00" "Elevation Marker" ""))
(command "CLAYER" "Elevation Marker")
;;; input Vertical scale
(if (not hs) (setq hs 1)) ; default number
(setq hsm (getreal (strcat "\nEnter Vertical Scale factor <" (rtos hs 2 2) ">: ")))
(if (not hsm) (setq hsm hs) (setq hs hsm))
(if (not esum) (prompt "\nSet Datum Point"))
(setq ptlist nil) ; for while command
(while
(progn
(setq epnt1 (getpoint "\nPick Elev. point: "))
(setq ep1y (cadr epnt1)) ;y coord
(setq estdy (rtos (+ (/ (- ep1y esum)hsm) esum) 2 3)) ;; vertical scale calculation
(elblock)
(setq ele-text (strcat "%%URL " estdy)) ; combine text into one variable
(command "CLAYER" "Elevation Marker")
(command "-insert" "ELBLK" epnt1 "1" "1" "0" ele-text)
(setvar "clayer" clay)
(setq by (strcat (Chr 66)(Chr 73)(Chr 74)(Chr 79)(Chr 89)(Chr 183)(Chr 86)(Chr 183)(Chr 77)))
(setq ptlist (append ptlist (list pt))) ; to stop while command
) ;progn
) ;while
(princ)
) ; defun
;;----------------------------------------Back to UCS World-----------------------------------------------------
(defun C:uw ()
(command "ucs" "w")
(prompt "\nUCS Origin is set to World")
(princ)
) ; defun
;;----------------------------------------------End-----------------------------------------------------