help with a slope lisp

Hi .I am useing this code , but i need to do some changes

1) i want the text insert automatcaly in the midle of the line (above the line with a litle space)

2) This code clculate the slope % . if the slope is 0,02 wrte 2% but if the slope is 0,002 % writes 0.2%. I ant to write 2‰ .

(defun c:TanLineanot(/	   doc	    spc	     *error*  TH:UnDo
	  TH:StartUnDo	    p1	     p2	      p3       scl   ht
	  tan2	   TL-Line  TH:UnDo
	 )
;;; Authour : Hasan Asos    -> Modified by Tharwat 
 (vl-load-com)
(COMMAND "_layer" "_m" "_slope" "_c" "140" "" "")
(command "-style" "_TanLine" "wgsimpl.shx" "_annotative" "_yes" "_no" 1.75 1.0 0.0 "_no" "_no" "" "")
 (and (setq doc (cond (doc)
	       ((vla-get-ActiveDocument (vlax-get-Acad-Object)))
	 )
      )
      (setq spc (if (zerop (vla-get-activespace doc))
	   (if (= (vla-get-mspace doc) :vlax-true)
	     (vla-get-modelspace doc)
	     (vla-get-paperspace doc)
	   )
	   (vla-get-modelspace doc)
	 )
      )
 )
 (defun *error* (msg)
   (and TH:UnDo (vla-EndUndoMark doc))
   (or	(wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **"))
   )
   (princ)
 )
 (setq TH:StartUnDo (vla-StartUndoMark doc))
 (initget "Line Points")
 (if (eq (setq	TL-sel
	 (getkword (strcat "\nselect line or points[Line/Points]: " "< Line >"))
  )
  "Points"
     )
   (progn
        (setq p1 (getpoint "\n select the first point : "))
     (setq p2 (getpoint p1 "\n select the second point : "))
     (setq p3 (getpoint "\n pick a point : "))
         (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
     (entmake (list (cons 0 "LINE")
	     (cons 10 (trans p1 1 0))
	     (cons 11 (trans p2 1 0))
       )
     )
    (vla-AddText spc (strcat (rtos (abs (* tan2 100)) 2 2) "%") (vlax-3d-point (trans p3 1 0))  (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue)))

   )
   (progn
     (prompt "\n select a line : ")
     (setq TL-Line (ssget '((0 . "LINE"))))
     (setq e (ssname TL-Line 0))
     (setq p1 (cdr (assoc 10 (entget e))))
     (setq p2 (cdr (assoc 11 (entget e))))
     (setq p3 (getpoint "\n pick a point : "))
     (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
     (vla-AddText spc (strcat (rtos (abs (* tan2 100)) 2 2) "%") (vlax-3d-point (trans p3 1 0))  (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue)))

   )
 )
 (setq TH:UnDo (vla-EndUndoMark Doc))
 (princ "\n ")
 (princ)
)

Thanks

similar old thread?

it has minor bug haven't fixed cant test now, enjoying oldtown white coffee at the moment

I want to ask a question. when i piick points at the end create a line and a text with the slope.I don't want the line , but i can not find what to delete in the code.Can any one help?

i think is

 (entmake (list (cons 0 "LINE")
	     (cons 10 (trans p1 1 0))
	     (cons 11 (trans p2 1 0))
       )
     )

but is not working

thanks

I have a version works with lines and plines.

; xfall as a percentage 
; Modified to work with plines 
; By Alan H July 2017

;(defun trap (errmsg)
;  (prompt "\nAn error has occured.")
;  (command "undo" "b")
;  (setvar "osmode" os)
;  (setq *error* temperr)


(defun rtd (a)(/ (*  a 180.0) pi))
(setvar "TEXTSTYLE" "STANDARD")
; cross fall as a percentage 
; modified to recognise a pline
; By Alan H July 2017
(defun c:xfallper ( / pt1 pt2 pt3 pt4 )
(setvar "cmdecho" 0)

(SETQ ANGBASEE (GETVAR "ANGBASE"))
(SETQ ANGDIRR (GETVAR "ANGDIR"))
(SETQ LUNITSS (GETVAR "LUNITS"))
(SETQ LUPRECC (GETVAR "LUPREC"))
(SETQ AUNITSS (GETVAR "AUNITS"))
(SETQ AUPRECC (GETVAR "AUPREC"))

(SETVAR "LUNITS" 2)
(SETVAR "ANGBASE" 0.0)
(SETVAR "ANGDIR" 0)
(SETVAR "LUPREC" 3)
(SETVAR "AUNITS" 0)
(SETVAR "AUPREC" 3)

(setq os (getvar "osmode"))
(setvar "osmode" 0)

(if (= horiz nil)
(progn
(if (not AH:getval3)(load "getvals3"))
(ah:getval3 "Enter Horizontal scale " 5 4 "100" "Enter Vertical scale" 5 4 "50" "Enter number of decimal places" 5 4 "2")
(setq horiz (atof val1))
(setq vert (atof val2))
(setq prec (atoi val3))
)
)

(alert "Pick lines or plines")

(while (setq s (entsel "Select line"))
(setq objname (cdr (assoc 0 (entget (car s)))))

(if (=  objname  "LWPOLYLINE")
(progn
(setq pr (vlax-curve-getparamatpoint (car s) (setq p (vlax-curve-getclosestpointto (car s) (cadr s)))))
(setq pt1 (vlax-curve-getpointatparam (car s) (fix pr)))
(setq pt2 (vlax-curve-getpointatparam (car s) (1+ (fix pr))))
(setq found "Y")
)
)

(if (=  objname  "LINE")
(progn
(setq pt1 (cdr (assoc 10 (entget (car s)))))
(setq pt2 (cdr (assoc 11 (entget (car s)))))
(setq found "Y")
)
)

(if (= Found nil)
(progn
(alert "Do again object has no slope")
(exit)
)
)

(setq pt1x (car pt1))
(setq pt1y (cadr pt1))
(setq pt2x (car pt2))
(setq pt2y (cadr pt2))

(setq ydist (abs (- pt1y pt2y)))
(setq xdist (abs (- pt1x pt2x)))
(setq xfall (strcat (rtos  (* (/ (* ydist vert) (* xdist horiz)) 100) 2 prec) "%") )
(setq ang (angle pt1 pt2))
(setq dist (distance pt1 pt2))
(if (> dist 0)
(progn 
(setq halfdist (/ dist 2))
(setq pt3 (polar pt1 ang halfdist))
(if (> ang pi) (setq ang (- ang pi)))
(if (> ang (/ pi 2)) (setq pt4ang (- ang (/ pi 2))) (setq pt4ang (+ ang (/ pi 2))))
(setq pt4 (polar pt3 pt4ang 0.75))
(if (> ang (/ pi 2)) (setq ang (+ ang pi)))
(setq tang (rtd ang)) 
)
)
(command "TEXT" pt4 2.5 tang xfall "")
(setq s nil)

) ;while
;  (setvar "DIMZIN" dimz)
(setvar "cmdecho" 1)
(setvar "osmode" os)
;  (setq *error* temperr)
(SETVAR "LUNITS" lunitss)
(SETVAR "ANGBASE" angbasee)
(SETVAR "ANGDIR" angdirr)
(SETVAR "LUPREC" luprecc)
(SETVAR "AUNITS" aunitss)
(SETVAR "AUPREC" auprecc)


(princ)
) ;defun

GETVALS3.lsp

Sorry Biggal is not working

prodromosm, did you load the attached file (GETVALS3.lsp) that BIGAL shows above? The program won't work without it.

Yes i load them from tha same path.But is not working. I am using Autocad 2017

Hmmm... well, I'm sure BIGAL will respond to this thread when he gets time. In the meantime, I'll throw this one out there. I use it when I just want the slope between two points. Could be a line, pline or any two points selected.

Just something else to look at.

;; Run this program by picking two points and using them to define the slope of the line.
;;
;; Program by BKT (Sept. 2007)
;;
;; 8/7/2017 - Modified to use and reset current TEXTANGLE.
;; 8/13/2017 - Modified to use PER MILLE "\U+2030" symbol instead of "%" where applicable.
;;

(defun C:slpe (/ osm pt1 pt2 d1 d2 rise run rmid1 rmid2 mid percenttext slope angdeg tngl)

(setq tngl (getvar "TEXTANGLE"))
(setq osm (getvar "osmode"))

;;Error handler
(setq olderr *error*)
(defun *error* (msg)
  (if (or
        (= msg "Function canceled")
        (= msg "quit / exit abort")
      )
    ;;if user canceled or program aborted, exit quietly
    (princ)
    ;;otherwise report error message
    (princ (strcat "\nError: " msg))
  )
 (prompt "\n Program Terminated")
 (setvar "osmode"osm)
 (princ)
)

(setvar "cmdecho" 0) 
  (setq pt1 (getpoint "\nPick Start Point: ")
        pt2 (getpoint "\nPick End Point: ")
        d1 (/ (distance pt1 pt2) 12)
        d2 (rtos d1 2 2)
        rise (- (cadr pt2) (cadr pt1)) run (- (car pt2) (car pt1))
        rmid1 (/ (+ (car pt2) (car pt1)) 2) rmid2 (/ (+ (cadr pt1) (cadr pt2)) 2)
        mid (strcat (rtos rmid1) "," (rtos rmid2))
  )

(IF (= (- (car pt2) (car pt1)) 0.00) (alert "\nAngle Equals 90 Degrees!"))

(setq slope (/ rise run)
     angdeg (angtos (atan rise run) 1 4)
)

(IF (< slope 0.01)
     (setq percenttext (strcat (rtos (* 1000 slope) 2 2) "\U+2030"))
     (setq percenttext (strcat (rtos (* 100 slope) 2 2) "%"))
)

(setvar "osmode" 0)

(command "TEXT" "J" "BC" mid (getvar "TEXTSIZE") angdeg percenttext)

(setvar "TEXTANGLE" tngl)
(setvar "osmode" osm)
(princ)
)

Edit: Never mind - recent changes make this only work properly in the positive quadrant. I'll look at it again when I get a minute.

I copied and pasted from the forum the code and it worked fine.

Did this pop up ? The code allows for slopes on cross and long sections rather than 2 3d points. If its not scaled just set the hor and vertical to 100

BKT maybe look at the angle between the two points, if you set to say radians then zero direction right you know which quadrant your in so can reverse angle etc and then convert to slope. Other way is to reverse the two points using a check on x1-x2 is it + or -, went left or right, same with Y1-Y2.

Thanks, BIGAL! When I get a little time to myself I'll go over these. Where did all my spare time go?

I want to ask a question. when i piick points at the end create a line and a text with the slope.I don't want the line , but i can not find what to delete in the code.Can any one help?

 

i think is

 

 (entmake (list (cons 0 "LINE")
	     (cons 10 (trans p1 1 0))
	     (cons 11 (trans p2 1 0))
       )
     )

 

but is not working

it should be no line created if entmake is removed in your code , what is not working ?

Or have you tested function from the old thread mentioned?

Just supply point argument..

 
(defun c:test (  / p1 p2)
(while
(and(setq p1 (getpoint "\nStart point"))(setq p2 (getpoint "\nEnd point")))
(hp:grad% 1. 1. p1 p2)
)
(princ)
)

BKT maybe look at the angle between the two points, if you set to say radians then zero direction right you know which quadrant your in so can reverse angle etc and then convert to slope. Other way is to reverse the two points using a check on x1-x2 is it + or -, went left or right, same with Y1-Y2.

another

;assume p1 is base of quadrant ASTC {All++ Sin-+ Tan-- Cos+-}
; (cadr(mapcar '<= p1 p2)) or (cadr(mapcar '>= p2 p1)); predicate Y= positive (A or S)

;example:
((if(cadr(mapcar '<= p1 p2)) + -) number ) 


(car(mapcar '<= p1 p2)); predicate X= positive (A or C)