;;;
;;; Author: Henry C. Francis
;;; 425 N. Ashe St.
;;; Southern Pines, NC 28387
;;;
;;; http://www.paracadd.com
;;; All rights reserved.
;;;
;;; Copyright: 11-18-2014
;;; Edited: 11-18-2014
;;;
(DEFUN C:SLOPEBYTEXT (/
first_ent
first_sta_pt
first_txt
first_txt_lst
new_slope_txt
second_ent
second_sta_pt
second_txt
second_txt_lst
slope_ent
slope_sel
slope_txt
slope_txt_lst
text-rise
text-run
this_slope
)
(PRINC "\nSelect first Invert text: ") ;must end in ###.#'
(PRINC)
(SETQ first_ent (ENTSEL))
(PRINC "\nSelect second Invert text: ")
;;must end in ###.#'
(PRINC)
(SETQ second_ent (ENTSEL))
(IF first_ent
(SETQ first_txt (CDR (ASSOC 1 (ENTGET (CAR first_ent)))))
) ;_ end of IF
(IF second_ent
(SETQ second_txt (CDR (ASSOC 1 (ENTGET (CAR second_ent)))))
) ;_ end of IF
(IF (AND first_txt second_txt)
(PROGN
(IF check_for_doslib
NIL
(LOAD "check_for_doslib" "\nFile CHECK_FOR_DOSLIB.LSP not loaded! ")
) ;_ end of IF
(check_for_doslib)
(IF DOS_STRTOKENS
(PROGN
(SETQ first_txt_lst (DOS_STRTOKENS first_txt " '"))
(SETQ second_txt_lst (DOS_STRTOKENS second_txt " '"))
(IF upoint
NIL
(LOAD "upoint" "\nFile UPOINT.LSP not loaded! ")
) ;_ end of IF
(SETQ first_sta_pt (upoint 1 "" "First station point (Y-value is ignored)" NIL NIL))
(SETQ second_sta_pt (upoint 1 "" "Second station point (Y-value is ignored)" NIL NIL))
(SETQ text-run (- (MAX (CAR first_sta_pt) (CAR second_sta_pt)) (MIN (CAR first_sta_pt) (CAR second_sta_pt))))
(COND
((AND (MEMBER "OUT" first_txt_lst) (MEMBER "IN" second_txt_lst))
(SETQ text-rise (- (ATOF (CADR (REVERSE first_txt_lst))) (ATOF (CADR (REVERSE second_txt_lst)))))
(PRINC (STRCAT "\nRise = "
(CADR (REVERSE first_txt_lst))
"-"
(CADR (REVERSE second_txt_lst))
" = "
(RTOS text-rise 2 3)
) ;_ end of STRCAT
) ;_ end of PRINC
)
((AND (MEMBER "IN" first_txt_lst) (MEMBER "OUT" second_txt_lst))
(SETQ text-rise (- (ATOF (CADR (REVERSE second_txt_lst))) (ATOF (CADR (REVERSE first_txt_lst)))))
(PRINC (STRCAT "\nRise = "
(CADR (REVERSE second_txt_lst))
"-"
(CADR (REVERSE first_txt_lst))
" = "
(RTOS text-rise 2 3)
) ;_ end of STRCAT
) ;_ end of PRINC
)
) ;_ end of COND
(PRINC (STRCAT "\nRun = "
(RTOS (MAX (CAR first_sta_pt) (CAR second_sta_pt)) 2 3)
"-"
(RTOS (MIN (CAR first_sta_pt) (CAR second_sta_pt)) 2 3)
" = "
(RTOS text-run 2 3)
) ;_ end of STRCAT
) ;_ end of PRINC
(SETQ this_slope (/ text-rise text-run))
(IF ureal
NIL
(LOAD "ureal" "\nFile UREAL.LSP not loaded! ")
) ;_ end of IF
(IF this_slope_prec
NIL
(SETQ this_slope_prec
(ureal 1
""
"Enter # of slope decimal places"
(IF this_slope_prec
this_slope_prec
2
) ;_ end of IF
) ;_ end of ureal
) ;_ end of SETQ
)
(PRINC
(STRCAT "\nSlope = " (RTOS this_slope 2 5) " = " (RTOS (* this_slope 100.0) 2 this_slope_prec) "%")
) ;_ end of PRINC
(PRINC)
(PRINC "\nSelect slope text to update: ")
(PRINC)
(SETQ slope_sel (ENTSEL))
(IF (AND slope_sel (EQ (CDR (ASSOC 0 (ENTGET (CAR slope_sel)))) "TEXT"))
(PROGN
(SETQ slope_ent (ENTGET (CAR slope_sel)))
(SETQ slope_txt (CDR (ASSOC 1 slope_ent)))
(WHILE (WCMATCH slope_txt "*%%")
(SETQ slope_txt (SUBSTR slope_txt 1 (1- (STRLEN slope_txt))))
) ;_ end of WHILE
(SETQ slope_txt_lst (DOS_STRTOKENS slope_txt " %"))
(IF (AND (EQ (TYPE (READ (CADR (REVERSE slope_txt_lst)))) 'REAL)
(EQ (CAR (REVERSE slope_txt_lst)) "")
(WCMATCH slope_txt "*%")
) ;_ end of AND
(PROGN
(SETQ slope_txt_lst (MAPCAR '(LAMBDA (x) (STRCAT x " ")) slope_txt_lst))
(SETQ slope_txt_lst
(REVERSE
(CONS "%" (CONS (RTOS (* this_slope 100.0) 2 this_slope_prec) (CDDR (REVERSE slope_txt_lst))))
) ;_ end of REVERSE
) ;_ end of SETQ
(SETQ new_slope_txt (EVAL (CONS 'STRCAT slope_txt_lst)))
(WHILE (WCMATCH new_slope_txt "*%%")
(SETQ new_slope_txt (SUBSTR new_slope_txt 1 (1- (STRLEN new_slope_txt))))
) ;_ end of WHILE
(SETQ slope_ent (SUBST (CONS 1 new_slope_txt) (ASSOC 1 slope_ent) slope_ent))
(ENTMOD slope_ent)
) ;_ end of PROGN
(PROGN
(ALERT "Selected slope text must end in a real followed by a percent sign, e.g., \"#.##%\"")
(PRINC "slope_txt_lst=")
(PRINC slope_txt_lst)
(PRINC "slope_txt=")
(PRINC slope_txt)
(PRINC)
) ;_ end of PROGN
) ;_ end of IF
) ;_ end of PROGN
) ;_ end of IF
) ;_ end of PROGN
(PROGN
(ALERT "Download and install DOSLIB from Robert McNeel & Associates to use this program")
) ;_ end of PROGN
) ;_ end of IF
) ;_ end of PROGN
(ALERT "You must select two text entites with invert values for the slope you want to calculate.")
) ;_ end of IF
(PRINC)
) ;_ end of DEFUN
;;;******************************************************************************
(DEFUN C:RESETRIM (/
cnt
col-cnt
dot-cnt
last-num-cnt
mh-ent
mh-ent-lay
mh-grph-ent
new-rim-txt
num-cnt
rimset_ss
rim_pt
this-txt
this-txt-ent
this_rim
)
(IF dimscl
NIL
(LOAD "dimscl" "\nFile DIMSCL.LSP not loaded! ")
) ;_ end of IF
(dimscl)
(IF ureal
NIL
(LOAD "ureal" "\nFile UREAL.LSP not loaded! ")
) ;_ end of IF
(SETQ this_rim (ureal 1
""
"Enter rim"
(IF this_rim
this_rim
NIL
) ;_ end of IF
) ;_ end of ureal
) ;_ end of SETQ
(IF upoint
NIL
(LOAD "upoint" "\nFile UPOINT.LSP not loaded! ")
) ;_ end of IF
(SETQ rim_pt (upoint 1 "" "select current rim point" NIL NIL))
(SETQ mh-grph-ent (SSGET "F" (LIST (POLAR rim_pt PI 0.1) (POLAR rim_pt 0.0 0.1)) '((0 . "POLYLINE"))))
(IF mh-grph-ent
(PROGN
(SETQ mh-ent (ENTGET (SSNAME mh-grph-ent 0)))
(SETQ mh-ent-lay (CDR (ASSOC 8 mh-ent)))
(IF v_fact
(STRCAT "Current vertical scale factor is " (RTOS v_fact 2 2) ".") ; Enter vertical scale factor")
(SETQ v_fact (ureal 1 "" (STRCAT "Enter vertical scale factor") 10.0))
) ;_ end of IF
(PRINC "\nSelect the manhole label elements. ")
(SETQ rimset_ss (SSGET))
(SETQ cnt 0)
(WHILE (< cnt (SSLENGTH rimset_ss))
(IF (AND (SETQ this-txt-ent (ENTGET (SSNAME rimset_ss cnt)))
(EQ (CDR (ASSOC 0 this-txt-ent)) "TEXT")
(WCMATCH (SETQ this-txt (CDR (ASSOC 1 this-txt-ent))) "*RIM*")
) ;_ end of AND
(PROGN
(SETQ col-cnt 1)
(WHILE (NOT (WCMATCH (SUBSTR this-txt col-cnt) "RIM*"))
(SETQ col-cnt (1+ col-cnt))
) ;_ end of WHILE
(SETQ num-cnt col-cnt)
(WHILE (NOT (WCMATCH (SUBSTR this-txt num-cnt) "#*"))
(SETQ num-cnt (1+ num-cnt))
) ;_ end of WHILE
(SETQ dot-cnt num-cnt)
(WHILE (NOT (WCMATCH (SUBSTR this-txt dot-cnt) "`.*"))
(SETQ dot-cnt (1+ dot-cnt))
) ;_ end of WHILE
(SETQ last-num-cnt (1+ dot-cnt))
(WHILE (WCMATCH (SUBSTR this-txt last-num-cnt) "#*")
(SETQ last-num-cnt (1+ last-num-cnt))
) ;_ end of WHILE
(SETQ new-rim-txt
(STRCAT
(SUBSTR this-txt 1 (1- num-cnt))
(RTOS this_rim 2 (- last-num-cnt (1+ dot-cnt)))
(SUBSTR this-txt last-num-cnt)
) ;_ end of STRCAT
) ;_ end of SETQ
(SETQ this-txt-ent
(SUBST (CONS 1 new-rim-txt) (ASSOC 1 this-txt-ent) this-txt-ent)
) ;_ end of SETQ
(ENTMOD this-txt-ent)
) ;_ end of PROGN
) ;_ end of IF
(SETQ cnt (1+ cnt))
) ;_ end of WHILE
(COMMAND "STRETCH"
"cp"
"non"
(POLAR (POLAR rim_pt PI 0.5) (* PI 1.5) 0.5)
"non"
(POLAR (POLAR rim_pt 0.0 0.5) (* PI 1.5) 0.5)
"non"
(POLAR (POLAR rim_pt 0.0 0.5) (* PI 0.5) 0.5)
"non"
(POLAR (POLAR rim_pt PI 0.5) (* PI 0.5) 0.5)
""
"r"
(SSGET "X"
'((-4 . "")
)
) ;_ end of SSGET
""
"non"
rim_pt
"non"
(POLAR rim_pt (* PI 0.5) (- (* this_rim v_fact) (CADR rim_pt)))
""
""
) ;_ end of COMMAND
(COMMAND "MOVE"
rimset_ss
""
"non"
rim_pt
"non"
(POLAR rim_pt (* PI 0.5) (- (* this_rim v_fact) (CADR rim_pt)))
""
) ;_ end of COMMAND
(PRINC (STRCAT "Moved manhole label elements " (RTOS (- (* this_rim v_fact) (CADR rim_pt)) 2 2)))
(PRINC)
) ;_ end of PROGN
) ;_ end of IF
(PRINC)
) ;_ end of DEFUN
;|«Visual LISP© Format Options»
(120 2 15 2 T "end of " 100 9 0 0 nil nil T nil T)
;*** DO NOT add text below the comment! ***|;