Need help to get slope polylines 2D

Hi all,

I want get and show slope of polylines.

ex:

- Select polylines in the Drawing

- Input height text (example: a)

- Show slope and the arrow (b=a/2)

- If Point B 's Y coordinate > Point A 's Y coordinate

direction of the arrow: B --> A

Thanks!

Here, play with this code, but orientation of arrows and sign of slope is always in direction POLYGON was drawn... I understood what you wanted, but it's not so simple to realize having in mind that polygon can have many slopes and many top-bottom vertices and we are not sure if bottom vertex of one slope wouldn't be top vertex of another one... My version is much more reliable for general case situations...

(defun c:slopepol ( / osm pl ptlst a b l s mptlst mid otxts tanptlst slopelst anglst )

 (defun mid ( p1 p2 )
   (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
 )

 (command "_.ucs" "_W")
 (setq osm (getvar 'osmode))
 (setvar 'osmode 0)
 (while (not pl)
   (setq pl (car (entsel "\nSelect open LWPOLYLINE-POLYGON that lies in WCS")))
   (if (not (and pl (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE") (eq (logand (cdr (assoc 70 (entget pl))) 1) 0) (equal (assoc 210 (entget pl)) '(210 0.0 0.0 1.0)) (vl-every '(lambda ( x ) (= 0.0 (cdr x))) (vl-remove-if-not '(lambda ( x ) (= 42 (car x))) (entget pl)))))
     (progn
       (prompt "\nMissed selection, or picked wrong entity (not LWPOLYLINE), or picked LWPOLYLINE isn't open, or LWPOLYLINE doesn't lie in WCS, or LWPOLYLINE isn't POLYGON (has arced segments)... Try again...")
       (setq pl nil)
     )
   )
 )
 (setq ptlst (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget pl))))
 (initget 7)
 (setq a (getdist "\nSpecify height for slope text : "))
 (setq b (/ a 2.0))
 (setq l (entmakex (list '(0 . "LINE") (cons 10 (list (- a) b 0.0)) (cons 11 (list a b 0.0)))))
 (setq s (entmakex (list '(0 . "SOLID") (cons 10 (polar (list a b 0.0) (+ pi (/ pi 12.0)) b)) (cons 11 (list a b 0.0)) (cons 12 (polar (list a b 0.0) (- pi (/ pi 12.0)) b)) (cons 13 (polar (list a b 0.0) (- pi (/ pi 12.0)) b)))))
 (command "_.block" "arrow" '(0.0 0.0 0.0) (ssadd s (ssadd l)) "")
 (setq mptlst (mapcar '(lambda ( v1 v2 ) (mid v1 v2)) ptlst (cdr ptlst)))
 (setq otxts (getvar 'textsize))
 (setvar 'textsize a)
 (setq tanptlst (mapcar '(lambda ( v1 v2 ) (/ (- (cadr v2) (cadr v1)) (- (car v2) (car v1)))) ptlst (cdr ptlst)))
 (setq slopelst (mapcar '(lambda ( x ) (* x 100.0)) tanptlst))
 (setq anglst (mapcar '(lambda ( v1 v2 ) (cvunit (angle v1 v2) "radians" "degrees")) ptlst (cdr ptlst)))
 (mapcar '(lambda ( x y z )
           (command "_.insert" "arrow" x "" "" y)
           (command "_.text" "_J" "_BC" (polar x (+ (/ pi 2.0) (cvunit y "degrees" "radians")) a) "" y (strcat (rtos z 2 2) " %"))
          ) mptlst anglst slopelst
 )
 (setvar 'osmode osm)
 (setvar 'textsize otxts)
 (princ)
)

HTH, M.R.

Thanks you!

Here, play with this code, but orientation of arrows and sign of slope is always in direction POLYGON was drawn... I understood what you wanted, but it's not so simple to realize having in mind that polygon can have many slopes and many top-bottom vertices and we are not sure if bottom vertex of one slope wouldn't be top vertex of another one... My version is much more reliable for general case situations...

 

(defun c:slopepol ( / osm pl ptlst a b l s mptlst mid otxts tanptlst slopelst anglst )

 (defun mid ( p1 p2 )
   (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
 )

 (command "_.ucs" "_W")
 (setq osm (getvar 'osmode))
 (setvar 'osmode 0)
 (while (not pl)
   (setq pl (car (entsel "\nSelect open LWPOLYLINE-POLYGON that lies in WCS")))
   (if (not (and pl (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE") (eq (logand (cdr (assoc 70 (entget pl))) 1) 0) (equal (assoc 210 (entget pl)) '(210 0.0 0.0 1.0)) (vl-every '(lambda ( x ) (= 0.0 (cdr x))) (vl-remove-if-not '(lambda ( x ) (= 42 (car x))) (entget pl)))))
     (progn
       (prompt "\nMissed selection, or picked wrong entity (not LWPOLYLINE), or picked LWPOLYLINE isn't open, or LWPOLYLINE doesn't lie in WCS, or LWPOLYLINE isn't POLYGON (has arced segments)... Try again...")
       (setq pl nil)
     )
   )
 )
 (setq ptlst (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget pl))))
 (initget 7)
 (setq a (getdist "\nSpecify height for slope text : "))
 (setq b (/ a 2.0))
 (setq l (entmakex (list '(0 . "LINE") (cons 10 (list (- a) b 0.0)) (cons 11 (list a b 0.0)))))
 (setq s (entmakex (list '(0 . "SOLID") (cons 10 (polar (list a b 0.0) (+ pi (/ pi 12.0)) b)) (cons 11 (list a b 0.0)) (cons 12 (polar (list a b 0.0) (- pi (/ pi 12.0)) b)) (cons 13 (polar (list a b 0.0) (- pi (/ pi 12.0)) b)))))
 (command "_.block" "arrow" '(0.0 0.0 0.0) (ssadd s (ssadd l)) "")
 (setq mptlst (mapcar '(lambda ( v1 v2 ) (mid v1 v2)) ptlst (cdr ptlst)))
 (setq otxts (getvar 'textsize))
 (setvar 'textsize a)
 (setq tanptlst (mapcar '(lambda ( v1 v2 ) (/ (- (cadr v2) (cadr v1)) (- (car v2) (car v1)))) ptlst (cdr ptlst)))
 (setq slopelst (mapcar '(lambda ( x ) (* x 100.0)) tanptlst))
 (setq anglst (mapcar '(lambda ( v1 v2 ) (cvunit (angle v1 v2) "radians" "degrees")) ptlst (cdr ptlst)))
 (mapcar '(lambda ( x y z )
           (command "_.insert" "arrow" x "" "" y)
           (command "_.text" "_J" "_BC" (polar x (+ (/ pi 2.0) (cvunit y "degrees" "radians")) a) "" y (strcat (rtos z 2 2) " %"))
          ) mptlst anglst slopelst
 )
 (setvar 'osmode osm)
 (setvar 'textsize otxts)
 (princ)
)

HTH, M.R.

this is very useful....but there is problem that is when i do twice in the same drawing there is error like this ".block

Enter block name or [?]: arrow Block "arrow" already exists. Redefine it?

[Yes/No] : 0.000000000000000,0.000000000000000

Yes or No, please.

; error: Function cancelled"

this error came from the arrow block.after removing and purge working properly please help me to solve this.even without arrow also suitable for my work

thanks

chinthaka

This should work multiple times in one session... Watch for highlighted text if you want to use it without arrows...

(defun c:slopepol ( / osm pl ptlst a b l s mptlst mid otxts tanptlst slopelst anglst )

 (defun mid ( p1 p2 )
   (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
 )

 (command "_.ucs" "_W")
 (setq osm (getvar 'osmode))
 (setvar 'osmode 0)
 (while (not pl)
   (setq pl (car (entsel "\nSelect open LWPOLYLINE-POLYGON that lies in WCS")))
   (if (not (and pl (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE") (eq (logand (cdr (assoc 70 (entget pl))) 1) 0) (equal (assoc 210 (entget pl)) '(210 0.0 0.0 1.0)) (vl-every '(lambda ( x ) (= 0.0 (cdr x))) (vl-remove-if-not '(lambda ( x ) (= 42 (car x))) (entget pl)))))
     (progn
       (prompt "\nMissed selection, or picked wrong entity (not LWPOLYLINE), or picked LWPOLYLINE isn't open, or LWPOLYLINE doesn't lie in WCS, or LWPOLYLINE isn't POLYGON (has arced segments)... Try again...")
       (setq pl nil)
     )
   )
 )
 (setq ptlst (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget pl))))
 (initget 7)
 (setq a (getdist "\nSpecify height for slope text : "))
 (setq b (/ a 2.0))
 [highlight];;; => if you don't want arrows comment this block of lines with [color=red];|[/color] sign before paragraph and with [color=red]|;[/color] sign after...
 ;;; [color=red];|[/color][/highlight]
 (if (not (tblsearch "BLOCK" "ARROW"))
   (progn
     (setq l (entmakex (list '(0 . "LINE") (cons 10 (list (- a) b 0.0)) (cons 11 (list a b 0.0)))))
     (setq s (entmakex (list '(0 . "SOLID") (cons 10 (polar (list a b 0.0) (+ pi (/ pi 12.0)) b)) (cons 11 (list a b 0.0)) (cons 12 (polar (list a b 0.0) (- pi (/ pi 12.0)) b)) (cons 13 (polar (list a b 0.0) (- pi (/ pi 12.0)) b)))))
     (command "_.block" "arrow" '(0.0 0.0 0.0) (ssadd s (ssadd l)) "")
   )
 )
 [highlight];;; [color=red]|;[/color][/highlight]
 (setq mptlst (mapcar '(lambda ( v1 v2 ) (mid v1 v2)) ptlst (cdr ptlst)))
 (setq otxts (getvar 'textsize))
 (setvar 'textsize a)
 (setq tanptlst (mapcar '(lambda ( v1 v2 ) (/ (- (cadr v2) (cadr v1)) (- (car v2) (car v1)))) ptlst (cdr ptlst)))
 (setq slopelst (mapcar '(lambda ( x ) (* x 100.0)) tanptlst))
 (setq anglst (mapcar '(lambda ( v1 v2 ) (cvunit (angle v1 v2) "radians" "degrees")) ptlst (cdr ptlst)))
 (mapcar '(lambda ( x y z )
           (command "_.insert" "arrow" x "" "" y)  [highlight];;; => if you don't want arrows comment this line with [color=red];[/color] sign before line [/highlight]
           (command "_.text" "_J" "_BC" (polar x (+ (/ pi 2.0) (cvunit y "degrees" "radians")) a) "" y (strcat (rtos z 2 2) " %"))
          ) mptlst anglst slopelst
 )
 (setvar 'osmode osm)
 (setvar 'textsize otxts)
 (command "_.ucs" "_P")
 (princ)
)

HTH, M.R.

This should work multiple times in one session... Watch for highlighted text if you want to use it without arrows...

 

(defun c:slopepol ( / osm pl ptlst a b l s mptlst mid otxts tanptlst slopelst anglst )

 (defun mid ( p1 p2 )
   (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
 )

 (command "_.ucs" "_W")
 (setq osm (getvar 'osmode))
 (setvar 'osmode 0)
 (while (not pl)
   (setq pl (car (entsel "\nSelect open LWPOLYLINE-POLYGON that lies in WCS")))
   (if (not (and pl (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE") (eq (logand (cdr (assoc 70 (entget pl))) 1) 0) (equal (assoc 210 (entget pl)) '(210 0.0 0.0 1.0)) (vl-every '(lambda ( x ) (= 0.0 (cdr x))) (vl-remove-if-not '(lambda ( x ) (= 42 (car x))) (entget pl)))))
     (progn
       (prompt "\nMissed selection, or picked wrong entity (not LWPOLYLINE), or picked LWPOLYLINE isn't open, or LWPOLYLINE doesn't lie in WCS, or LWPOLYLINE isn't POLYGON (has arced segments)... Try again...")
       (setq pl nil)
     )
   )
 )
 (setq ptlst (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget pl))))
 (initget 7)
 (setq a (getdist "\nSpecify height for slope text : "))
 (setq b (/ a 2.0))
 [highlight];;; => if you don't want arrows comment this block of lines with [color=red];|[/color] sign before paragraph and with [color=red]|;[/color] sign after...
 ;;; [color=red];|[/color][/highlight]
 (if (not (tblsearch "BLOCK" "ARROW"))
   (progn
     (setq l (entmakex (list '(0 . "LINE") (cons 10 (list (- a) b 0.0)) (cons 11 (list a b 0.0)))))
     (setq s (entmakex (list '(0 . "SOLID") (cons 10 (polar (list a b 0.0) (+ pi (/ pi 12.0)) b)) (cons 11 (list a b 0.0)) (cons 12 (polar (list a b 0.0) (- pi (/ pi 12.0)) b)) (cons 13 (polar (list a b 0.0) (- pi (/ pi 12.0)) b)))))
     (command "_.block" "arrow" '(0.0 0.0 0.0) (ssadd s (ssadd l)) "")
   )
 )
 [highlight];;; [color=red]|;[/color][/highlight]
 (setq mptlst (mapcar '(lambda ( v1 v2 ) (mid v1 v2)) ptlst (cdr ptlst)))
 (setq otxts (getvar 'textsize))
 (setvar 'textsize a)
 (setq tanptlst (mapcar '(lambda ( v1 v2 ) (/ (- (cadr v2) (cadr v1)) (- (car v2) (car v1)))) ptlst (cdr ptlst)))
 (setq slopelst (mapcar '(lambda ( x ) (* x 100.0)) tanptlst))
 (setq anglst (mapcar '(lambda ( v1 v2 ) (cvunit (angle v1 v2) "radians" "degrees")) ptlst (cdr ptlst)))
 (mapcar '(lambda ( x y z )
           (command "_.insert" "arrow" x "" "" y)  [highlight];;; => if you don't want arrows comment this line with [color=red];[/color] sign before line [/highlight]
           (command "_.text" "_J" "_BC" (polar x (+ (/ pi 2.0) (cvunit y "degrees" "radians")) a) "" y (strcat (rtos z 2 2) " %"))
          ) mptlst anglst slopelst
 )
 (setvar 'osmode osm)
 (setvar 'textsize otxts)
 (command "_.ucs" "_P")
 (princ)
)

HTH, M.R.

wow...thank you very much dear Marko Rebar....you are a great person it is working properly.thank u again ur quick reply....

Hello bro, sorry, I'm inexpert. How can I have the slope in degrees instead percentage?

7 hours ago, JuanArevaloOchoa said:

Hello bro, sorry, I'm inexpert. How can I have the slope in degrees instead percentage?

(defun c:slopepol ( / osm pl ptlst a b l s mptlst mid otxts tanptlst slopelst anglst )

  (defun mid ( p1 p2 )
    (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
  )

  (command "_.ucs" "_W")
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (while (not pl)
    (setq pl (car (entsel "\nSelect open LWPOLYLINE-POLYGON that lies in WCS")))
    (if (not (and pl (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE") (eq (logand (cdr (assoc 70 (entget pl))) 1) 0) (equal (assoc 210 (entget pl)) '(210 0.0 0.0 1.0)) (vl-every '(lambda ( x ) (= 0.0 (cdr x))) (vl-remove-if-not '(lambda ( x ) (= 42 (car x))) (entget pl)))))
      (progn
        (prompt "\nMissed selection, or picked wrong entity (not LWPOLYLINE), or picked LWPOLYLINE isn't open, or LWPOLYLINE doesn't lie in WCS, or LWPOLYLINE isn't POLYGON (has arced segments)... Try again...")
        (setq pl nil)
      )
    )
  )
  (setq ptlst (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget pl))))
  (initget 7)
  (setq a (getdist "\nSpecify height for slope text : "))
  (setq b (/ a 2.0))
  ;;; ;|
  (if (not (tblsearch "BLOCK" "ARROW"))
    (progn
      (setq l (entmakex (list '(0 . "LINE") (cons 10 (list (- a) b 0.0)) (cons 11 (list a b 0.0)))))
      (setq s (entmakex (list '(0 . "SOLID") (cons 10 (polar (list a b 0.0) (+ pi (/ pi 12.0)) b)) (cons 11 (list a b 0.0)) (cons 12 (polar (list a b 0.0) (- pi (/ pi 12.0)) b)) (cons 13 (polar (list a b 0.0) (- pi (/ pi 12.0)) b)))))
      (command "_.block" "arrow" '(0.0 0.0 0.0) (ssadd s (ssadd l)) "")
    )
  )
  ;;; |;
  (setq mptlst (mapcar '(lambda ( v1 v2 ) (mid v1 v2)) ptlst (cdr ptlst)))
  (setq otxts (getvar 'textsize))
  (setvar 'textsize a)
  ;;; (setq tanptlst (mapcar '(lambda ( v1 v2 ) (/ (- (cadr v2) (cadr v1)) (- (car v2) (car v1)))) ptlst (cdr ptlst)))
  ;;; (setq slopelst (mapcar '(lambda ( x ) (* x 100.0)) tanptlst))
  (setq anglst (mapcar '(lambda ( v1 v2 ) (cvunit (angle v1 v2) "radians" "degrees")) ptlst (cdr ptlst)))
  (mapcar '(lambda ( x y )
            (command "_.insert" "arrow" x "" "" y)  ;;; comment this line if you don't want arrows and also comment above paragraph with creation of arrow block
            (command "_.text" "_J" "_BC" (polar x (+ (/ pi 2.0) (cvunit y "degrees" "radians")) a) "" y (strcat (rtos y 2 2) " °"))
           ) mptlst anglst
  )
  (setvar 'osmode osm)
  (setvar 'textsize otxts)
  (command "_.ucs" "_P")
  (princ)
)

HTH., M.R.

Following on an oldie origin 2010 Horizontal & Vertical scale taken into account. Version handles pline segments. 

; 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 ans pr pt1x pt1y pt2x pt2 ans) 
(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" 3)
(SETVAR "AUPREC" 3)
 
(setq os (getvar "osmode"))
(setvar "osmode" 0)
 
(if (= horiz nil)
(progn
(if (not AH:getvalsm)(load "Multi getvals"))
(setq ans (ah:getvalsm (list "Xfall per by %" "Enter Horizontal scale " 5 4 "100" "Enter Vertical scale" 5 4 "50" "Enter number of decimal places" 5 4 "2")))
(setq horiz (atof (nth 0 ans)))
(setq vert (atof (nth 1 ans)))
(setq prec (atoi (nth 2 ans)))
)
)
 
(alert "Pick lines or plines")
 
(while (setq s (entsel "Select line pick nothing to exit"))
(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 cursty (getvar 'textstyle))
(setq tsty (vla-get-textstyles (vla-get-activedocument (vlax-get-acad-object))))
(vlax-for ent tsty
(if (= (vla-get-name ent) cursty)
(setq txtht (vla-get-height ent))
)
)

(if (= txtht 0.0)
(command "TEXT" pt4 2.5 ang xfall)
(command "TEXT" pt4 ang xfall )
)

(setq s nil)
 
) 
;  (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

Multi GETVALS.lsp

Hi all,

I love the basic of the LISP,  we only need the arrow for the direction. We don't want to use other LISPS with the option to change the linetype. 

For now I was able to change the LISP, so it only ask for the text height and after giving a height only the arrow is placed. Is it possible to edit the LISP so the arrow is direct placed after selecting the polyline?

Thanks!