Draw vector on 3dface the direction of flow.

carlos_m_gil_p · ‎03-29-2017

Hello boys how are you.

Could you help me with this lisp.
I need to draw a vector on 3dfaces.
Show direction of flow of water.

Attached dwg file to understand me.

Excuse my English, I only speak Spanish.
Thank you very much.

AutoCAD 2026
Visual Studio Code 1.99.3
AutoCAD AutoLISP Extension 1.6.3
Windows 10 (64 bits)

_gile · ‎03-29-2017

Hi,

You probably can get tome inspiration from this quite old one I translated the prompts and comments:

;; S3DF (Gilles Chanteau) 2010/03/23
;; Insert the "SLOPE_ARROW" block on all selected 3D faces.
;; The block is created if not found in the drawing.
;; An invisible attrib contains the slope value (%), you can set ATTMODE to 2 to display it.

(defun c:S3DF (/  size  n	 ss   ent  new	elst p1	  p2   p3   cg	 no
	       pgp  lst	 minp maxp moy	l0   l1	  l2   l3   l4	 l5
	       l6   l7	 l8
	      )
  (initget 5)
  (setq size (getdist "\nSpecify the arrows size: "))
  ;; Create the layer if not already exists
  (if (not (tblsearch "LAYER" "SLOPE_ARROW"))
    (entmake '((0 . "LAYER")
	       (100 . "AcDbSymbolTableRecord")
	       (100 . "AcDbLayerTableRecord")
	       (2 . "SLOPE_ARROW")
	       (70 . 0)
	       (62 . 3)
	       (6 . "Continuous")
	      )
    )
  )

  ;; Create the block if not already exists
  (if (not (tblsearch "BLOCK" "SLOPE_ARROW"))
	(progn
	  (entmake
	    '((0 . "BLOCK")
	      (100 . "AcDbEntity")
	      (8 . "0")
	      (100 . "AcDbBlockBegin")
	      (2 . "SLOPE_ARROW")
	      (70 . 2)
	      (10 0.0 0.0 0.0)
	     )
	  )
	  (entmake
	    '((0 . "LINE")
	      (8 . "0")
	      (62 . 0)
	      (10 -0.5 0. 0.)
	      (11 0.5 0. 0.)
	     )
	  )
	  (entmake
	    '((0 . "LINE")
	      (8 . "0")
	      (62 . 0)
	      (10 0.5 0. 0.)
	      (11 0.25 0.1 0.)
	     )
	  )
	  (entmake
	    '((0 . "LINE")
	      (8 . "0")
	      (62 . 0)
	      (10 0.5 0. 0.)
	      (11 0.25 -0.1 0.)
	     )
	  )
	  (entmake
	    '((0 . "ATTDEF")
	      (100 . "AcDbEntity")
	      (8 . "0")
	      (62 . 0)
	      (100 . "AcDbText")
	      (10 0.0 0.0 0.0)
	      (40 . 0.08)
	      (1 . "0")
	      (50 . 0.0)
	      (72 . 1)
	      (11 0.0 0.0 0.0)
	      (100 . "AcDbAttributeDefinition")
	      (3 . "Pente ?")
	      (2 . "PENTE")
	      (70 . 9)
	      (74 . 1)
	      (280 . 1)
	     )
	  )
	  (entmake '((0 . "ENDBLK") (8 . "0")))
	)
      )
  
  ;; Process the selection set
  (if (and (setq n  -1
		 l0 0
		 l8 0
		 ss (ssget '((0 . "3DFACE")))
	   )
      )
    (while (setq ent (ssname ss (setq n (1+ n))))
      ;; divide the face if it is a 4 edges face
      (if (setq new (Triang3dFace ent))
	(ssadd new ss)
      )
      (setq elst (entget ent)
	    p1	 (cdr (assoc 10 elst))
	    p2	 (cdr (assoc 11 elst))
	    p3	 (cdr (assoc 12 elst))
      )
      (if
	(and
	  (setq	cg (mapcar
		     '(lambda (x1 x2 x3) (/ (+ x1 x2 x3) 3.))
		     p1
		     p2
		     p3
		   )
	  )
	  ;; normal of the face
	  (setq no (v^v (mapcar '- p2 p1) (mapcar '- p3 p1)))
	  (not (equal '(0. 0. 0.) no 1e-9))
	  (setq	no (if (minusp (caddr no))
		     (mapcar '- no)
		     no
		   )
	  )
	  (setq pgp (vpgp no))		; greatest slope vector
	)
	 (progn
	   (setq ins (trans cg 0 no)
		 slp (*	-100
			(/ (caddr pgp)
			   (distance '(0. 0.)
				     (list (car pgp) (cadr pgp))
			   )
			)
		     )
	   )
	   (entmake
	     (list '(0 . "INSERT")
		   '(66 . 1)
		   '(2 . "SLOPE_ARROW")
		   '(8 . "SLOPE_ARROW")
		   (cons 10 (trans cg 0 no))
		   (cons 50 (angle '(0. 0. 0.) (trans pgp 0 no)))
		   (cons 41 size)
		   (cons 42 size)
		   (cons 43 size)
		   (cons 210 no)
	     )
	   )
	   (entmake
	     (list '(0 . "ATTRIB")
		   '(62 . 0)
		   (cons 10 ins)
		   (cons 40 (* 0.08 size))
		   (cons
		     1
		     (if (equal pgp '(0. 0. -1.) 1e-9)
		       "Vertical"
		       (strcat (rtos slp 2 2) "%")
		     )
		   )
		   (cons 50 (angle '(0. 0. 0.) (trans pgp 0 no)))
		   '(72 . 1)
		   (cons 11 ins)
		   '(2 . "PENTE")
		   (cons 210 no)
		   '(70 . 9)
		   '(74 . 1)
		   '(280 . 1)
	     )
	   )
	   (entmake '((0 . "SEQEND")))
	   (if (equal pgp '(0. 0. -1.) 1e-9)
	     (setq l8 (1+ l8))
	     (setq lst
		    (cons
		      (cons
			(entlast)
			(* -100.
			   (/ (caddr pgp)
			      (distance '(0. 0.) (list (car pgp) (cadr pgp)))
			   )
			)
		      )
		      lst
		    )
	     )
	   )
	 )
	(progn
	  (entmake
	    (list
	      '(0 . "CIRCLE")
	      '(8 . "SLOPE_ARROW")
	      (cons 10 (trans cg 0 no))
	      (cons 40 (/ size 4.))
	      '(62 . 30)
	      (cons 210 no)
	    )
	  )
	  (setq l0 (1+ l0))
	)
      )
    )
  )
  (setq	minp (apply 'min (mapcar 'cdr lst))
	maxp (apply 'max (mapcar 'cdr lst))
	moy  (/ (- maxp minp) 7.)
  )
  (foreach l '(l1 l2 l3 l4 l5 l6 l7) (set l 0))
  (foreach p lst
    (cond
      ((<= (cdr p) (+ minp moy))
       (setq l1 (1+ l1))
       (entmod (append (entget (car p)) (list '(62 . 1))))
      )
      ((<= (cdr p) (+ minp (* 2 moy)))
       (setq l2 (1+ l2))
       (entmod (append (entget (car p)) (list '(62 . 2))))
      )
      ((<= (cdr p) (+ minp (* 3 moy)))
       (setq l3 (1+ l3))
       (entmod (append (entget (car p)) (list '(62 . 3))))
      )
      ((<= (cdr p) (+ minp (* 4 moy)))
       (setq l4 (1+ l4))
       (entmod (append (entget (car p)) (list '(62 . 4))))
      )
      ((<= (cdr p) (+ minp (* 5 moy)))
       (setq l5 (1+ l5))
       (entmod (append (entget (car p)) (list '(62 . 5))))
      )
      ((<= (cdr p) (+ minp (* 6 moy)))
       (setq l6 (1+ l6))
       (entmod (append (entget (car p)) (list '(62 . 6))))
      )
      (T
       (setq l7 (1+ l7))
       (entmod (append (entget (car p)) (list '(62 . 7))))
      )
    )
  )
  (if (setq pt (getpoint "\nSpecify the legend insertion point: "))
    (entmake
      (list
	'(0 . "MTEXT")
	'(100 . "AcDbEntity")
	'(8 . "LEGENDE")
	'(100 . "AcDbMText")
        (cons 40 size)
	(cons 10 (trans pt 1 0))
	(cons 1
	      (strcat
		"{\\C1;from "
		(rtos minp)
		"% to "
		(rtos (+ minp moy))
		"% ("
		(itoa l1)
		" faces)\\P\\C2;from "
		(rtos (+ minp moy))
		"% to "
		(rtos (+ minp (* 2 moy)))
		"% ("
		(itoa l2)
		" faces)\\P\\C3;from "
		(rtos (+ minp (* 2 moy)))
		"% to "
		(rtos (+ minp (* 3 moy)))
		"% ("
		(itoa l3)
		" faces)\\P\\C4;from "
		(rtos (+ minp (* 3 moy)))
		"% to "
		(rtos (+ minp (* 4 moy)))
		"% ("
		(itoa l4)
		" faces)\\P\\C5;from "
		(rtos (+ minp (* 4 moy)))
		"% to "
		(rtos (+ minp (* 5 moy)))
		"% ("
		(itoa l5)
		" faces)\\P\\C6;from "
		(rtos (+ minp (* 5 moy)))
		"% to "
		(rtos (+ minp (* 6 moy)))
		"% ("
		(itoa l6)
		" faces)\\P\\C7;from "
		(rtos (+ minp (* 6 moy)))
		"% to "
		(rtos maxp)
		"% ("
		(itoa l7)
		" faces)}"
		(if (< 0 l0)
		  (strcat "\n" (itoa l0) " horizontal faces")
		  ""
		)
		(if (< 0 l8)
		  (strcat "\n" (itoa l0) " vertical faces")
		  ""
		)
	      )
	)
      )
    )
  )
  (princ)
)

;; V^V
;; Returns the croos product of two vectors
;;
;; Arguments : two vectors

(defun v^v (v1 v2)
  (list	(- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
	(- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
	(- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
  )
)

;; VUNIT
;; Returns the unit vector of a vector
;;
;; Argument : a vector

(defun vunit (v)
  ((lambda (l)
     (if (/= 0 l)
       (mapcar (function (lambda (x) (/ x l))) v)
     )
   )
    (distance '(0 0 0) v)
  )
)

;; VPGP
;; Returns the unit greatest slope vector of a plane
;; defined by its normal (nil if horizontal plane)
;;
;; Argument : the normal vector of the plane

(defun vpgp (norm)
  (if (/= 0 (caddr norm))
    ((lambda (d)
       (vunit
	 (list (car norm) (cadr norm) (/ (* d d) (- (caddr norm))))
       )
     )
      (distance '(0. 0.) (list (car norm) (cadr norm)))
    )
    '(0. 0. -1.)
  )
)

;; Triang3dFace
;; Divide a 4 edges 3D face into two triangular 3D faces or 'standardize' 
;; the triangular face (3rd and 4th vertices overlapped)
;; Returns the ename of the newly created 3D face or nil if the face was already triangular
;;
;; Argument : a 3D face (ENAME)

(defun Triang3dFace	(f3d / p1 p2 p3 p4)
  (setq	elst (entget f3d)
	p1   (cdr (assoc 10 elst))
	p2   (cdr (assoc 11 elst))
	p3   (cdr (assoc 12 elst))
	p4   (cdr (assoc 13 elst))
  )
  (cond
    ((equal p3 p4 1e-9) nil)
    ((equal p1 p2 1e-9)
     (entmod (subst (cons 11 p3)
		    (assoc 11 elst)
		    (subst (cons 12 p4) (assoc 12 elst) elst)
	     )
     )
     nil
    )
    ((equal p1 p4 1e-9)
     (entmod (subst (cons 13 p3) (assoc 13 elst) elst))
     nil
    )
    ((equal p2 p3 1e-9)
     (entmod (subst (cons 12 p4) (assoc 12 elst) elst))
     nil
    )
    (T
     (if (< (distance p2 p4) (distance p1 p3))
       (progn
	 (entmod
	   (subst (cons 12 p4) (assoc 12 elst) elst)
	 )
	 (entmakex
	   (subst (cons 10 p2)
		  (assoc 10 elst)
		  (subst (cons 11 p3)
			 (assoc 11 elst)
			 (subst (cons 12 p4) (assoc 12 elst) elst)
		  )
	   )
	 )
       )
       (progn
	 (entmod (subst (cons 13 p3) (assoc 13 elst) elst))
	 (entmakex
	   (subst (cons 11 p3)
		  (assoc 11 elst)
		  (subst (cons 12 p4) (assoc 12 elst) elst)
	   )
	 )
       )
     )
    )
  )
)

Gilles Chanteau
Programmation AutoCAD LISP/.NET
GileCAD
GitHub

_gile · ‎03-30-2017

This one is closer to the drawing example (colors from 60 to 160 incremented by 10)

;; S3DF (gile)
;; Insert the "SLOPE_ARROW" block on all selected 3D faces

(defun c:S3DF (/ size n ss ent new elst p1 p2 p3 cg no pgp lst minp maxp moy l0 l1 l2 l3 l4 l5 l6 l7 l8 l9 l10 l11 l12)
  (initget 5)
  (setq size (getdist "\nSpecify the arrows size: "))
  ;; Create the layer if not already exists
  (if (not (tblsearch "LAYER" "SLOPE_ARROW"))
    (entmake '((0 . "LAYER")
               (100 . "AcDbSymbolTableRecord")
               (100 . "AcDbLayerTableRecord")
               (2 . "SLOPE_ARROW")
               (70 . 0)
               (62 . 3)
               (6 . "Continuous")
              )
    )
  )

  ;; Create the block if not already exists
  (if (not (tblsearch "BLOCK" "SLOPE_ARROW"))
    (progn
      (entmake
        '((0 . "BLOCK")
          (100 . "AcDbEntity")
          (8 . "0")
          (100 . "AcDbBlockBegin")
          (2 . "SLOPE_ARROW")
          (70 . 2)
          (10 0.0 0.0 0.0)
         )
      )
      (entmake
        '((0 . "LINE")
          (8 . "0")
          (62 . 0)
          (10 -0.5 0. 0.)
          (11 0.5 0. 0.)
         )
      )
      (entmake
        '((0 . "LINE")
          (8 . "0")
          (62 . 0)
          (10 0.5 0. 0.)
          (11 0.25 0.1 0.)
         )
      )
      (entmake
        '((0 . "LINE")
          (8 . "0")
          (62 . 0)
          (10 0.5 0. 0.)
          (11 0.25 -0.1 0.)
         )
      )
      (entmake
        '((0 . "ATTDEF")
          (100 . "AcDbEntity")
          (8 . "0")
          (62 . 0)
          (100 . "AcDbText")
          (10 0.0 0.0 0.0)
          (40 . 0.08)
          (1 . "0")
          (50 . 0.0)
          (72 . 1)
          (11 0.0 0.0 0.0)
          (100 . "AcDbAttributeDefinition")
          (3 . "Pente ?")
          (2 . "PENTE")
          (70 . 9)
          (74 . 1)
          (280 . 1)
         )
      )
      (entmake '((0 . "ENDBLK") (8 . "0")))
    )
  )

  ;; Process the selection set
  (if (and (setq n  -1
                 l0 0
                 l8 0
                 ss (ssget '((0 . "3DFACE")))
           )
      )
    (while (setq ent (ssname ss (setq n (1+ n))))
      ;; divide the face if it is a 4 edges face
      (if (setq new (Triang3dFace ent))
        (ssadd new ss)
      )
      (setq elst (entget ent)
            p1   (cdr (assoc 10 elst))
            p2   (cdr (assoc 11 elst))
            p3   (cdr (assoc 12 elst))
            no   (v^v (mapcar '- p2 p1) (mapcar '- p3 p1)) ; normal of the face
      )
      (if (not (equal '(0. 0. 0.) no 1e-9))
        (if
          (and
            (setq cg (mapcar
                       '(lambda (x1 x2 x3) (/ (+ x1 x2 x3) 3.))
                       p1
                       p2
                       p3
                     )
            )
            (setq no (if (minusp (caddr no))
                       (mapcar '- no)
                       no
                     )
            )
            (setq pgp (vpgp no))        ; greatest slope vector
          )
           (progn
             (setq ins (trans cg 0 no)
                   slp (* -100
                          (/ (caddr pgp)
                             (distance '(0. 0.)
                                       (list (car pgp) (cadr pgp))
                             )
                          )
                       )
             )
             (entmake
               (list '(0 . "INSERT")
                     '(66 . 1)
                     '(2 . "SLOPE_ARROW")
                     '(8 . "SLOPE_ARROW")
                     (cons 10 (trans cg 0 no))
                     (cons 50 (angle '(0. 0. 0.) (trans pgp 0 no)))
                     (cons 41 size)
                     (cons 42 size)
                     (cons 43 size)
                     (cons 210 no)
               )
             )
             (entmake
               (list '(0 . "ATTRIB")
                     '(62 . 0)
                     (cons 10 ins)
                     (cons 40 (* 0.08 size))
                     (cons
                       1
                       (if (equal pgp '(0. 0. -1.) 1e-9)
                         "Vertical"
                         (strcat (rtos slp 2 2) "%")
                       )
                     )
                     (cons 50 (angle '(0. 0. 0.) (trans pgp 0 no)))
                     '(72 . 1)
                     (cons 11 ins)
                     '(2 . "PENTE")
                     (cons 210 no)
                     '(70 . 9)
                     '(74 . 1)
                     '(280 . 1)
               )
             )
             (entmake '((0 . "SEQEND")))
             (if (equal pgp '(0. 0. -1.) 1e-9)
               (setq l12 (1+ l11))
               (setq lst
                      (cons
                        (cons
                          (entlast)
                          (* -100.
                             (/ (caddr pgp)
                                (distance '(0. 0.) (list (car pgp) (cadr pgp)))
                             )
                          )
                        )
                        lst
                      )
               )
             )
           )
           (progn
             (entmake
               (list
                 '(0 . "CIRCLE")
                 '(8 . "SLOPE_ARROW")
                 (cons 10 (trans cg 0 no))
                 (cons 40 (/ size 4.))
                 '(62 . 30)
                 (cons 210 no)
               )
             )
             (setq l0 (1+ l0))
           )
        )
      )
    )
  )
  (setq minp (apply 'min (mapcar 'cdr lst))
        maxp (apply 'max (mapcar 'cdr lst))
        moy  (/ (- maxp minp) 12.)
  )
  (foreach l '(l1 l2 l3 l4 l5 l6 l7 l8 l9 l10 l11) (set l 0))
  (foreach p lst
    (cond
      ((<= (cdr p) (+ minp moy))
       (setq l1 (1+ l1))
       (entmod (append (entget (car p)) (list '(62 . 160))))
      )
      ((<= (cdr p) (+ minp (* 2 moy)))
       (setq l2 (1+ l2))
       (entmod (append (entget (car p)) (list '(62 . 150))))
      )
      ((<= (cdr p) (+ minp (* 3 moy)))
       (setq l3 (1+ l3))
       (entmod (append (entget (car p)) (list '(62 . 140))))
      )
      ((<= (cdr p) (+ minp (* 4 moy)))
       (setq l4 (1+ l4))
       (entmod (append (entget (car p)) (list '(62 . 130))))
      )
      ((<= (cdr p) (+ minp (* 5 moy)))
       (setq l5 (1+ l5))
       (entmod (append (entget (car p)) (list '(62 . 120))))
      )
      ((<= (cdr p) (+ minp (* 7 moy)))
       (setq l6 (1+ l6))
       (entmod (append (entget (car p)) (list '(62 . 110))))
      )
      ((<= (cdr p) (+ minp (* 8 moy)))
       (setq l7 (1+ l7))
       (entmod (append (entget (car p)) (list '(62 . 100))))
      )
      ((<= (cdr p) (+ minp (* 9 moy)))
       (setq l8 (1+ l8))
       (entmod (append (entget (car p)) (list '(62 . 90))))
      )
      ((<= (cdr p) (+ minp (* 10 moy)))
       (setq l9 (1+ l9))
       (entmod (append (entget (car p)) (list '(62 . 80))))
      )
      ((<= (cdr p) (+ minp (* 11 moy)))
       (setq l10 (1+ l10))
       (entmod (append (entget (car p)) (list '(62 . 70))))
      )
      (T
       (setq l11 (1+ l11))
       (entmod (append (entget (car p)) (list '(62 . 60))))
      )
    )
  )
  (if (setq pt (getpoint "\nSpecify the legend insertion point: "))
    (entmake
      (list
        '(0 . "MTEXT")
        '(100 . "AcDbEntity")
        '(8 . "LEGENDE")
        '(100 . "AcDbMText")
        (cons 40 size)
        (cons 10 (trans pt 1 0))
        (cons 1
              (strcat
                "{\\C160;from "
                (rtos minp)
                "% to "
                (rtos (+ minp moy))
                "% ("
                (itoa l1)
                " faces)\\P\\C150;from "
                (rtos (+ minp moy))
                "% to "
                (rtos (+ minp (* 2 moy)))
                "% ("
                (itoa l2)
                " faces)\\P\\C140;from "
                (rtos (+ minp (* 2 moy)))
                "% to "
                (rtos (+ minp (* 3 moy)))
                "% ("
                (itoa l3)
                " faces)\\P\\C130;from "
                (rtos (+ minp (* 3 moy)))
                "% to "
                (rtos (+ minp (* 4 moy)))
                "% ("
                (itoa l4)
                " faces)\\P\\C120;from "
                (rtos (+ minp (* 4 moy)))
                "% to "
                (rtos (+ minp (* 5 moy)))
                "% ("
                (itoa l5)
                " faces)\\P\\C110;from "
                (rtos (+ minp (* 5 moy)))
                "% to "
                (rtos (+ minp (* 6 moy)))
                "% ("
                (itoa l6)
                " faces)\\P\\C100;from "
                (rtos (+ minp (* 6 moy)))
                "% to "
                (rtos (+ minp (* 7 moy)))
                "% ("
                (itoa l7)
                " faces)\\P\\C90;from "
                (rtos (+ minp (* 7 moy)))
                "% to "
                (rtos (+ minp (* 8 moy)))
                "% ("
                (itoa l8)
                " faces)\\P\\C80;from "
                (rtos (+ minp (* 8 moy)))
                "% to "
                (rtos (+ minp (* 9 moy)))
                "% ("
                (itoa l9)
                " faces)\\P\\C70;from "
                (rtos (+ minp (* 9 moy)))
                "% to "
                (rtos (+ minp (* 10 moy)))
                "% ("
                (itoa l10)
                " faces)\\P\\C60;from "
                (rtos (+ minp (* 10 moy)))
                "% to "
                (rtos maxp)
                "% ("
                (itoa l11)
                " faces)}"
                (if (< 0 l0)
                  (strcat "\n" (itoa l0) " horizontal faces")
                  ""
                )
                (if (< 0 l12)
                  (strcat "\n" (itoa l12) " vertical faces")
                  ""
                )
              )
        )
      )
    )
  )
  (princ)
)

;; V^V
;; Returns the croos product of two vectors
;;
;; Arguments : two vectors

(defun v^v (v1 v2)
  (list (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
        (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
        (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
  )
)

;; VUNIT
;; Returns the unit vector of a vector
;;
;; Argument : a vector

(defun vunit (v)
  ((lambda (l)
     (if (/= 0 l)
       (mapcar (function (lambda (x) (/ x l))) v)
     )
   )
    (distance '(0 0 0) v)
  )
)

;; VPGP
;; Returns the unit greatest slope vector of a plane
;; defined by its normal (nil if horizontal plane)
;;
;; Argument : the normal vector of the plane

(defun vpgp (norm)
  (if (/= 0 (caddr norm))
    ((lambda (d)
       (vunit
         (list (car norm) (cadr norm) (/ (* d d) (- (caddr norm))))
       )
     )
      (distance '(0. 0.) (list (car norm) (cadr norm)))
    )
    '(0. 0. -1.)
  )
)

;; Triang3dFace
;; Divide a 4 edges 3D face into two triangular 3D faces or 'standardize' 
;; the triangular face (3rd and 4th vertices overlapped)
;; Returns the ename of the newly created 3D face or nil if the face was already triangular
;;
;; Argument : a 3D face (ENAME)

(defun Triang3dFace (f3d / p1 p2 p3 p4)
  (setq elst (entget f3d)
        p1   (cdr (assoc 10 elst))
        p2   (cdr (assoc 11 elst))
        p3   (cdr (assoc 12 elst))
        p4   (cdr (assoc 13 elst))
  )
  (cond
    ((equal p3 p4 1e-9) nil)
    ((equal p1 p2 1e-9)
     (entmod (subst (cons 11 p3)
                    (assoc 11 elst)
                    (subst (cons 12 p4) (assoc 12 elst) elst)
             )
     )
     nil
    )
    ((equal p1 p4 1e-9)
     (entmod (subst (cons 13 p3) (assoc 13 elst) elst))
     nil
    )
    ((equal p2 p3 1e-9)
     (entmod (subst (cons 12 p4) (assoc 12 elst) elst))
     nil
    )
    (T
     (if (< (distance p2 p4) (distance p1 p3))
       (progn
         (entmod
           (subst (cons 12 p4) (assoc 12 elst) elst)
         )
         (entmakex
           (subst (cons 10 p2)
                  (assoc 10 elst)
                  (subst (cons 11 p3)
                         (assoc 11 elst)
                         (subst (cons 12 p4) (assoc 12 elst) elst)
                  )
           )
         )
       )
       (progn
         (entmod (subst (cons 13 p3) (assoc 13 elst) elst))
         (entmakex
           (subst (cons 11 p3)
                  (assoc 11 elst)
                  (subst (cons 12 p4) (assoc 12 elst) elst)
           )
         )
       )
     )
    )
  )
)

Gilles Chanteau
Programmation AutoCAD LISP/.NET
GileCAD
GitHub

_gile · ‎03-30-2017

There's a mistake in the upper code.

Use this one instead.

;; S3DF (gile)
;; Insert the "SLOPE_ARROW" block on all selected 3D faces

(defun c:S3DF (/ size n ss ent new elst p1 p2 p3 cg no pgp lst minp maxp moy l0 l1 l2 l3 l4 l5 l6 l7 l8 l9 l10 l11 l12)
  (initget 5)
  (setq size (getdist "\nSpecify the arrows size: "))
  ;; Create the layer if not already exists
  (if (not (tblsearch "LAYER" "SLOPE_ARROW"))
    (entmake '((0 . "LAYER")
               (100 . "AcDbSymbolTableRecord")
               (100 . "AcDbLayerTableRecord")
               (2 . "SLOPE_ARROW")
               (70 . 0)
               (62 . 3)
               (6 . "Continuous")
              )
    )
  )

  ;; Create the block if not already exists
  (if (not (tblsearch "BLOCK" "SLOPE_ARROW"))
    (progn
      (entmake
        '((0 . "BLOCK")
          (100 . "AcDbEntity")
          (8 . "0")
          (100 . "AcDbBlockBegin")
          (2 . "SLOPE_ARROW")
          (70 . 2)
          (10 0.0 0.0 0.0)
         )
      )
      (entmake
        '((0 . "LINE")
          (8 . "0")
          (62 . 0)
          (10 -0.5 0. 0.)
          (11 0.5 0. 0.)
         )
      )
      (entmake
        '((0 . "LINE")
          (8 . "0")
          (62 . 0)
          (10 0.5 0. 0.)
          (11 0.25 0.1 0.)
         )
      )
      (entmake
        '((0 . "LINE")
          (8 . "0")
          (62 . 0)
          (10 0.5 0. 0.)
          (11 0.25 -0.1 0.)
         )
      )
      (entmake
        '((0 . "ATTDEF")
          (100 . "AcDbEntity")
          (8 . "0")
          (62 . 0)
          (100 . "AcDbText")
          (10 0.0 0.0 0.0)
          (40 . 0.08)
          (1 . "0")
          (50 . 0.0)
          (72 . 1)
          (11 0.0 0.0 0.0)
          (100 . "AcDbAttributeDefinition")
          (3 . "Pente ?")
          (2 . "PENTE")
          (70 . 9)
          (74 . 1)
          (280 . 1)
         )
      )
      (entmake '((0 . "ENDBLK") (8 . "0")))
    )
  )

  ;; Process the selection set
  (if (and (setq n  -1
                 l0 0
                 l8 0
                 ss (ssget '((0 . "3DFACE")))
           )
      )
    (while (setq ent (ssname ss (setq n (1+ n))))
      ;; divide the face if it is a 4 edges face
      (if (setq new (Triang3dFace ent))
        (ssadd new ss)
      )
      (setq elst (entget ent)
            p1   (cdr (assoc 10 elst))
            p2   (cdr (assoc 11 elst))
            p3   (cdr (assoc 12 elst))
            no   (v^v (mapcar '- p2 p1) (mapcar '- p3 p1)) ; normal of the face
      )
      (if (not (equal '(0. 0. 0.) no 1e-9))
        (if
          (and
            (setq cg (mapcar
                       '(lambda (x1 x2 x3) (/ (+ x1 x2 x3) 3.))
                       p1
                       p2
                       p3
                     )
            )
            (setq no (if (minusp (caddr no))
                       (mapcar '- no)
                       no
                     )
            )
            (setq pgp (vpgp no))        ; greatest slope vector
          )
           (progn
             (setq ins (trans cg 0 no)
                   slp (* -100
                          (/ (caddr pgp)
                             (distance '(0. 0.)
                                       (list (car pgp) (cadr pgp))
                             )
                          )
                       )
             )
             (entmake
               (list '(0 . "INSERT")
                     '(66 . 1)
                     '(2 . "SLOPE_ARROW")
                     '(8 . "SLOPE_ARROW")
                     (cons 10 (trans cg 0 no))
                     (cons 50 (angle '(0. 0. 0.) (trans pgp 0 no)))
                     (cons 41 size)
                     (cons 42 size)
                     (cons 43 size)
                     (cons 210 no)
               )
             )
             (entmake
               (list '(0 . "ATTRIB")
                     '(62 . 0)
                     (cons 10 ins)
                     (cons 40 (* 0.08 size))
                     (cons
                       1
                       (if (equal pgp '(0. 0. -1.) 1e-9)
                         "Vertical"
                         (strcat (rtos slp 2 2) "%")
                       )
                     )
                     (cons 50 (angle '(0. 0. 0.) (trans pgp 0 no)))
                     '(72 . 1)
                     (cons 11 ins)
                     '(2 . "PENTE")
                     (cons 210 no)
                     '(70 . 9)
                     '(74 . 1)
                     '(280 . 1)
               )
             )
             (entmake '((0 . "SEQEND")))
             (if (equal pgp '(0. 0. -1.) 1e-9)
               (setq l12 (1+ l11))
               (setq lst
                      (cons
                        (cons
                          (entlast)
                          (* -100.
                             (/ (caddr pgp)
                                (distance '(0. 0.) (list (car pgp) (cadr pgp)))
                             )
                          )
                        )
                        lst
                      )
               )
             )
           )
           (progn
             (entmake
               (list
                 '(0 . "CIRCLE")
                 '(8 . "SLOPE_ARROW")
                 (cons 10 (trans cg 0 no))
                 (cons 40 (/ size 4.))
                 '(62 . 30)
                 (cons 210 no)
               )
             )
             (setq l0 (1+ l0))
           )
        )
      )
    )
  )
  (setq minp (apply 'min (mapcar 'cdr lst))
        maxp (apply 'max (mapcar 'cdr lst))
        moy  (/ (- maxp minp) 11.)
  )
  (foreach l '(l1 l2 l3 l4 l5 l6 l7 l8 l9 l10 l11) (set l 0))
  (foreach p lst
    (cond
      ((<= (cdr p) (+ minp moy))
       (setq l1 (1+ l1))
       (entmod (append (entget (car p)) (list '(62 . 160))))
      )
      ((<= (cdr p) (+ minp (* 2 moy)))
       (setq l2 (1+ l2))
       (entmod (append (entget (car p)) (list '(62 . 150))))
      )
      ((<= (cdr p) (+ minp (* 3 moy)))
       (setq l3 (1+ l3))
       (entmod (append (entget (car p)) (list '(62 . 140))))
      )
      ((<= (cdr p) (+ minp (* 4 moy)))
       (setq l4 (1+ l4))
       (entmod (append (entget (car p)) (list '(62 . 130))))
      )
      ((<= (cdr p) (+ minp (* 5 moy)))
       (setq l5 (1+ l5))
       (entmod (append (entget (car p)) (list '(62 . 120))))
      )
      ((<= (cdr p) (+ minp (* 6 moy)))
       (setq l6 (1+ l6))
       (entmod (append (entget (car p)) (list '(62 . 110))))
      )
      ((<= (cdr p) (+ minp (* 7 moy)))
       (setq l7 (1+ l7))
       (entmod (append (entget (car p)) (list '(62 . 100))))
      )
      ((<= (cdr p) (+ minp (* 8 moy)))
       (setq l8 (1+ l8))
       (entmod (append (entget (car p)) (list '(62 . 90))))
      )
      ((<= (cdr p) (+ minp (* 9 moy)))
       (setq l9 (1+ l9))
       (entmod (append (entget (car p)) (list '(62 . 80))))
      )
      ((<= (cdr p) (+ minp (* 10 moy)))
       (setq l10 (1+ l10))
       (entmod (append (entget (car p)) (list '(62 . 70))))
      )
      (T
       (setq l11 (1+ l11))
       (entmod (append (entget (car p)) (list '(62 . 60))))
      )
    )
  )
  (if (setq pt (getpoint "\nSpecify the legend insertion point: "))
    (entmake
      (list
        '(0 . "MTEXT")
        '(100 . "AcDbEntity")
        '(8 . "LEGENDE")
        '(100 . "AcDbMText")
        (cons 40 size)
        (cons 10 (trans pt 1 0))
        (cons 1
              (strcat
                "{\\C160;from "
                (rtos minp)
                "% to "
                (rtos (+ minp moy))
                "% ("
                (itoa l1)
                " faces)\\P\\C150;from "
                (rtos (+ minp moy))
                "% to "
                (rtos (+ minp (* 2 moy)))
                "% ("
                (itoa l2)
                " faces)\\P\\C140;from "
                (rtos (+ minp (* 2 moy)))
                "% to "
                (rtos (+ minp (* 3 moy)))
                "% ("
                (itoa l3)
                " faces)\\P\\C130;from "
                (rtos (+ minp (* 3 moy)))
                "% to "
                (rtos (+ minp (* 4 moy)))
                "% ("
                (itoa l4)
                " faces)\\P\\C120;from "
                (rtos (+ minp (* 4 moy)))
                "% to "
                (rtos (+ minp (* 5 moy)))
                "% ("
                (itoa l5)
                " faces)\\P\\C110;from "
                (rtos (+ minp (* 5 moy)))
                "% to "
                (rtos (+ minp (* 6 moy)))
                "% ("
                (itoa l6)
                " faces)\\P\\C100;from "
                (rtos (+ minp (* 6 moy)))
                "% to "
                (rtos (+ minp (* 7 moy)))
                "% ("
                (itoa l7)
                " faces)\\P\\C90;from "
                (rtos (+ minp (* 7 moy)))
                "% to "
                (rtos (+ minp (* 8 moy)))
                "% ("
                (itoa l8)
                " faces)\\P\\C80;from "
                (rtos (+ minp (* 8 moy)))
                "% to "
                (rtos (+ minp (* 9 moy)))
                "% ("
                (itoa l9)
                " faces)\\P\\C70;from "
                (rtos (+ minp (* 9 moy)))
                "% to "
                (rtos (+ minp (* 10 moy)))
                "% ("
                (itoa l10)
                " faces)\\P\\C60;from "
                (rtos (+ minp (* 10 moy)))
                "% to "
                (rtos maxp)
                "% ("
                (itoa l11)
                " faces)}"
                (if (< 0 l0)
                  (strcat "\n" (itoa l0) " horizontal faces")
                  ""
                )
                (if (< 0 l12)
                  (strcat "\n" (itoa l12) " vertical faces")
                  ""
                )
              )
        )
      )
    )
  )
  (princ)
)

;; V^V
;; Returns the croos product of two vectors
;;
;; Arguments : two vectors

(defun v^v (v1 v2)
  (list (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
        (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
        (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
  )
)

;; VUNIT
;; Returns the unit vector of a vector
;;
;; Argument : a vector

(defun vunit (v)
  ((lambda (l)
     (if (/= 0 l)
       (mapcar (function (lambda (x) (/ x l))) v)
     )
   )
    (distance '(0 0 0) v)
  )
)

;; VPGP
;; Returns the unit greatest slope vector of a plane
;; defined by its normal (nil if horizontal plane)
;;
;; Argument : the normal vector of the plane

(defun vpgp (norm)
  (if (/= 0 (caddr norm))
    ((lambda (d)
       (vunit
         (list (car norm) (cadr norm) (/ (* d d) (- (caddr norm))))
       )
     )
      (distance '(0. 0.) (list (car norm) (cadr norm)))
    )
    '(0. 0. -1.)
  )
)

;; Triang3dFace
;; Divide a 4 edges 3D face into two triangular 3D faces or 'standardize' 
;; the triangular face (3rd and 4th vertices overlapped)
;; Returns the ename of the newly created 3D face or nil if the face was already triangular
;;
;; Argument : a 3D face (ENAME)

(defun Triang3dFace (f3d / p1 p2 p3 p4)
  (setq elst (entget f3d)
        p1   (cdr (assoc 10 elst))
        p2   (cdr (assoc 11 elst))
        p3   (cdr (assoc 12 elst))
        p4   (cdr (assoc 13 elst))
  )
  (cond
    ((equal p3 p4 1e-9) nil)
    ((equal p1 p2 1e-9)
     (entmod (subst (cons 11 p3)
                    (assoc 11 elst)
                    (subst (cons 12 p4) (assoc 12 elst) elst)
             )
     )
     nil
    )
    ((equal p1 p4 1e-9)
     (entmod (subst (cons 13 p3) (assoc 13 elst) elst))
     nil
    )
    ((equal p2 p3 1e-9)
     (entmod (subst (cons 12 p4) (assoc 12 elst) elst))
     nil
    )
    (T
     (if (< (distance p2 p4) (distance p1 p3))
       (progn
         (entmod
           (subst (cons 12 p4) (assoc 12 elst) elst)
         )
         (entmakex
           (subst (cons 10 p2)
                  (assoc 10 elst)
                  (subst (cons 11 p3)
                         (assoc 11 elst)
                         (subst (cons 12 p4) (assoc 12 elst) elst)
                  )
           )
         )
       )
       (progn
         (entmod (subst (cons 13 p3) (assoc 13 elst) elst))
         (entmakex
           (subst (cons 11 p3)
                  (assoc 11 elst)
                  (subst (cons 12 p4) (assoc 12 elst) elst)
           )
         )
       )
     )
    )
  )
)

Gilles Chanteau
Programmation AutoCAD LISP/.NET
GileCAD
GitHub

carlos_m_gil_p · ‎03-30-2017

Hello Brother how are you.

Thanks for helping.

The lisp works very well.

But I wanted to know if you can make some modifications.

Improve the color code.
Blue for the most flat and magenta the largest slope.
In the attached dwg file you can see it.

You can calculate the size of the arrow.
According to the size of the 3dfaces.
Do not enter the size yourself.

In the text of information. Percentage of slope.
Ignore the ones that say 3dfaces 0

You could use lisp with entities like polygonmesh.

Thank you so much for help me.
Thanks for your time.
I thank you with all my heart.

Forgive my English.

AutoCAD 2026
Visual Studio Code 1.99.3
AutoCAD AutoLISP Extension 1.6.3
Windows 10 (64 bits)

_gile · ‎03-30-2017

Sorry, I do not have the time now to give you free more than I have already done.
With the top routine, you have the main job done.
If you are not able to adapt it to your needs, you will have to wait for someone with enough free time to do it for you.

do it for you.

Gilles Chanteau
Programmation AutoCAD LISP/.NET
GileCAD
GitHub

carlos_m_gil_p · ‎03-30-2017

Hi brother, thank you very much for helping me.

I think I can change it.
What I'm afraid of is that I can be left with errors.
But I'm going to do it.

Thanks for your help.
Thanks for your time.
And I hope you continue to help all the people in this community.

A greeting and whatever you need, I am to order.

Thank you very much.

AutoCAD 2026
Visual Studio Code 1.99.3
AutoCAD AutoLISP Extension 1.6.3
Windows 10 (64 bits)

Community

Draw vector on 3dface the direction of flow.

Draw vector on 3dface the direction of flow.

Draw vector on 3dface the direction of flow.