Here is another update:
Added code to detect Expresstools and ignore the WIPEOUT if ET is not be loaded.
;;=========================================================================================
;; Slope Tag V1.2, 1989, '92
;; Revised 03/19/2005 - CAB Version 2.1
;; by RBCulp - Falcon Design Services, Inc.
;;
;; NO RIGHTS RESERVED; Any and all content may reproduced by any method on any medium for any reason.
;; Please, feel free to use any part found useful, interesting, enlightening or entertaining.
;; If by some chance, someone wishes to be credited for this, go right ahead.
;;
;; Falcon Design Services (FDS) provides this program "as is" and with all faults.
;; FDS specifically disclaims any implied warranty of merchantability or fitness for a particular use.
;; FDS does not warrant that the operation of the program will be uninterrupted or error free.
;;=========================================================================================
(defun c:sltag (/ scft nstelev nslope FIRSTPT PT1 PT2 distm dist1 nxtelev
*error* save_sys_vars restore_sys_vars make_block $elev)
;;===============================================
;; L o c a l F u n c t i o n s
;;===============================================
;; error function & Routine Exit
(defun *error* (msg)
(if
(not
(member
msg
'("console break" "Function cancelled" "quit / exit abort" "")
)
)
(princ (strcat "\nError: " msg))
) ; endif
(restore_sys_vars); reset vars
)
;; Function to save system variables in global variable
(defun save_sys_vars (lst)
(setq *sysvarlist* '())
(repeat (length lst)
(setq *sysvarlist* (append *sysvarlist* (list (list (car lst) (getvar (car lst))))))
(setq lst (cdr lst))
)
)
;; Function to reset system variables
(defun restore_sys_vars ()
(repeat (length *sysvarlist*)
(setvar (caar *sysvarlist*) (cadar *sysvarlist*))
(setq *sysvarlist* (cdr *sysvarlist*))
)
)
;;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
;; Make the elevation tag block
;;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
(defun make_block(blockname / et)
;; Check for ExpressTools
(if (member "acetutil.arx" (arx))
(if (wcmatch (getvar "ACADVER") "*16*")
(or (not (arxload "acwipeout")) (setq et T))
(or (not(member "wipeout.arx" (arx)))(setq et T))
)
)
(if (not et)
(alert "Express Tools are not Loaded \n Tag will be 'See Through'")
)
;;==============================================
;; Start of Block definition
;;==============================================
(entmake
(list '(0 . "BLOCK") ; required
'(100 . "AcDbEntity") ; recommended
'(100 . "AcDbBlockBegin") ; recommended
(cons 2 blockname) ; required
'(8 . "0") ; recommended
'(70 . 2) ; required [NOTE 0 if no attributes]
'(10 0.0 0.0 0.0) ; required
)
)
;;==============================================
;; Block objects
;;==============================================
;; NOTE: Wipeouts must be created first for other objects to be visable
(if et
(entmake '((0 . "WIPEOUT") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0")
(100 . "AcDbWipeout") (90 . 0) (10 0.0078125 -0.0859375 0.0) (11 0.625 0.0 0.0)
(12 0.0 0.625 0.0) (13 1.0 1.0 0.0) (70 . 7) (280 . 1)
(281 . 50) (282 . 50) (283 . 0) (71 . 2) (91 . 9) (14 -0.5 0.4625 0.0)
(14 -0.225 0.4625 0.0) (14 -0.225 0.5 0.0) (14 0.5 0.5 0.0) (14 0.5 0.225 0.0)
(14 -0.225 0.225 0.0) (14 -0.225 0.2625 0.0) (14 -0.5 0.2625 0.0) (14 -0.5 0.4625 0.0)))
)
(entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (100 . "AcDbText")
(10 0.279583 -0.05 0.0) (40 . 0.1) (1 . "") (50 . 0.0) (41 . 0.7) (51 . 0.0)
(7 . "Standard") (71 . 0) (72 . 1) (11 0.40625 0.0 0.0) (210 0.0 0.0 1.0)
(100 . "AcDbAttributeDefinition") (3 . "ELEV....") (2 . "ELEV") (70 . 0)
(73 . 0) (74 . 2)))
(entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0")
(100 . "AcDbPolyline") (90 . 4) (70 . 1) (43 . 0.0) (38 . 0.0) (39 . 0.0)
(10 0.183594 -0.0789062) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 0.628906 -0.0789062)
(40 . 0.0) (41 . 0.0) (42 . 0.0) (10 0.628906 0.0789062) (40 . 0.0) (41 . 0.0)
(42 . 0.0) (10 0.183594 0.0789062) (40 . 0.0) (41 . 0.0) (42 . 0.0) (210 0.0 0.0 1.0)))
(entmake '((0 . "TEXT") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0")
(100 . "AcDbText") (10 0.00806548 -0.05 0.0) (40 . 0.1) (1 . "I.E.") (50 . 0.0)
(41 . 0.8) (51 . 0.0) (7 . "Standard") (71 . 0) (72 . 2) (11 0.171875 0.0 0.0)
(210 0.0 0.0 1.0) (100 . "AcDbText") (73 . 2)))
;;==============================================
;; This is the end of block marker
;;==============================================
(entmake (list '(0 . "ENDBLK") ; required
'(100 . "AcDbBlockEnd") ; recommended
'(8 . "0") ; recommended
))
;;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
) ; end defun make_block
;;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
;;************************************************************************
;;************************************************************************
;; S T A R T O F R O U T I N E
;;************************************************************************
;;************************************************************************
;;------------------------------------------------------------------------
;; Set defaults on first use
;;------------------------------------------------------------------------
(or *stelev* (setq *stelev* 1200.00))
(or *slope* (setq *slope* -0.002))
(if (not (setq *units*
(car(member *units* '("Inch" "Foot" "Meter" "Centimeter")))))
(progn
(initget "Inch Foot Meter Centimeter")
(setq *units*
(getkword
"\nOne Unit in this drawing = [Inch/Foot/Meter/Centimeter] <Inch>:"))
(or *units* (setq *units* "Inch"))
)
)
;;------------------------------------------------------------------------
(save_sys_vars '("CMDECHO" "attdia" "attreq" "texteval"))
(command ".undo" "begin")
(setvar "cmdecho" 0)
(setvar "attdia" 0)
(setvar "attreq" 1)
(setvar "texteval" 1)
(setq scft (getvar "dimscale")
tunit (getvar "lunits")
distm 0)
;; ????????????????????
(cond
((= 2 tunit)
(setq tprec 3)
)
((= 4 tunit)
(setq tprec 4)
)
(T
(setq tprec 3)
)
) ; ?????????????????????
;;------------------------------------------------------------------------
(if (and (not (tblsearch "Block" "Ielev"))
(not (make_block "Ielev")))
(progn
(alert "Make Block Failed, can not continue.")
(exit)
)
)
(if (and
(or (not (setq nstelev
(getdist (strcat "Enter Starting Elevation <" (RTOS *stelev*) ">: "))))
(setq *stelev* nstelev))
(or (not (setq nslope (getreal (strcat "Enter Slope Factor (Negative For Down) <"
(RTOS *slope* 2 8) ">: " ))))
(setq *slope* nslope))
(setq FIRSTPT (getpoint "Select Starting point "))
(setq pt1 firstpt
nxtelev *stelev*)
) ; and
;;+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
(while (setq PT2 (getpoint PT1 "\n\nNext point "))
(setq dist1 (distance pt1 pt2)
distm (+ distm dist1)
nxtelev (+ (* dist1 *slope*) nxtelev)
PT1 PT2
)
(princ (strcat "\n Distance is " (rtos dist1)))
(princ (strcat "\n Slope is "
(rtos (* dist1 *slope*))))
(princ (strcat "\n Elevation is "
(rtos nxtelev tunit tprec)))
(princ (strcat "\n Running Total Distance is " (rtos distm)))
;;------------------------------------------------------------------------
(if (= *units* "Inch") ; convert to feet
(setq $elev (rtos (/ nxtelev 12.0) 2 2))
(setq $elev (rtos nxtelev 2 2))
)
(if (or (eq *units* "Inch") (eq *units* "Foot"))
(setq $elev (strcat $elev "'"))
)
(command "-insert" "Ielev" "s" scft "r" "45" pt2 $elev)
;;------------------------------------------------------------------------
) ; end while
;;+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
); endif
(princ (strcat "\n\n Final Total Distance is " (rtos distm)))
(command ".undo" "end")
(*error* "") ; restore variables
(princ)
)
(prompt "\n*** Slope Tag Loaded, Enter sltag to run. ***")
(princ)
;;=========================================================================================
;; eof