Topic: Elevations points

[ronjonp]

Glad to help 

[alanjt]

Here's an example I did similar to Ron's suggestion.

http://www.theswamp.org/screens/alanjt/AttBlock.gif

[Andrea]

one of mine...allow decimal digit, distance between text, text style, text size, orientation, Mtext with or without wipeout, or Text entity,...etc..

[alanjt]

In relation to contours, here's some I posed a while back:

http://www.theswamp.org/index.php?topic=39644.0

[sanju2323]

This lisp to different result of contour elevation

[Fabricio28]

Hi all
Thank you very much for the support!

Ron's tips is able to set elevation from specific point.

I have to draw 3DPolyline and create a point and use field position to get the elevation.
It's a  little laborious, but works great!

[sanju2323]

If you need contour cross line to 3D polyline

[Fabricio28]

If you need contour cross line to 3D polyline

Yes, I crossed contours line to 3D polyline and pick the elevation from a point in the 3D polyline.

Just like Ron said before.

Regards

[sanju2323]

test

[Fabricio28]

test

I'm trying to use your code, but I didn't get it.

Culd you explain for me please?

Regards

[sanju2323]

FABRICIO28,
          This lisp create 3Dpolyline from contour.

[Fabricio28]

FABRICIO28,
          This lisp create 3Dpolyline from contour.

Hi,
That code seems to be good, but my project doesn't have any contour to create 3Dpolyline.

What does countour is?

[mailmaverick]

My Code :

Code: [Select]

;;; This file writes Level of a point as per Selected Contours

(defun c:SpotElevfromContours ()
  (vl-load-com)
  ;;----------------
  ;; Functions
  ;;----------------
  (defun gc:distinctFuzz (lst fuzz)
    (if lst
      (cons (car lst) (gc:distinctFuzz (vl-remove-if '(lambda (x) (equal x (car lst) fuzz)) lst) fuzz))
    )
  )
  (defun CurrentZoomWindow (/ a b c d x)
    (setq b (getvar "viewsize")
  c (car (getvar "screensize"))
  d (cadr (getvar "screensize"))
  a (* b (/ c d))
  x (trans (getvar "viewctr") 1 2)
  c (list (- (car x) (/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0)
  d (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0)
  c (trans c 2 1)
  d (trans d 2 1)
    )
    (list c d)
  )
  (defun GetElevPoint (glpt sscont /   app    mind     elev     muSetpt1 mySetpt2 foundcontours rectsize increment     minx     miny     maxx     maxy pt1 pt2
       pt3 pt4 selset   ncont    entcont  ptcont   dd       fg       lenset lencnt found   val1    elev1    dist1    ent1     lin1     obj1 intcnt frstelev
       elev2 dist2
      )
    (setq app (vlax-get-acad-object))
    (setq mind 0)
    (setq elev "")
    (setq mySetpt1 (list))
    (setq mySetpt2 (list))
    (setq foundcontours 0)
    (setq rectsize 200.0)
    (setq increment 20.0)
    (while (eq foundcontours 0)
      (setq minx (- (car glpt) rectsize))
      (setq maxx (+ (car glpt) rectsize))
      (setq miny (- (cadr glpt) rectsize))
      (setq maxy (+ (cadr glpt) rectsize))
      (setq pt1 (list minx miny 0.0))
      (setq pt2 (list maxx miny 0.0))
      (setq pt3 (list maxx maxy 0.0))
      (setq pt4 (list minx maxy 0.0))
      (vla-zoomwindow app (vlax-3d-point pt1) (vlax-3d-point pt3))
      (if (setq selset (ACET-SS-INTERSECTION sscont (ssget "_CP" (list pt1 pt2 pt3 pt4) '((0 . "*POLYLINE")))))
(setq foundcontours 1)
      )
      (setq rectsize (+ rectsize increment))
    )
    (repeat (setq ncont (sslength selset))
      (setq entcont (ssname selset (setq ncont (1- ncont))))
      (setq elev (vla-get-elevation (vlax-ename->vla-object entcont)))
      (setq ptcont (vlax-curve-getclosestpointto entcont glpt))
      (setq ptcont (list (car ptcont) (cadr ptcont) (caddr glpt)))
      (setq dd (distance ptcont glpt))
      (setq mySetpt1 (append mySetpt1 (list (list elev dd ptcont entcont))))
    )
    (setq fg (vl-sort mySetpt1 '(lambda (e1 e2) (< (cadr e1) (cadr e2)))))
    (setq lenset (length fg))
    (setq lencnt 0)
    (setq found 0)
    (setq frstelev nil)
    (while (< lencnt lenset)
      (setq val1 (nth lencnt fg))
      (setq elev1 (car val1))
      (setq dist1 (cadr val1))
      (setq pt1 (caddr val1))
      (setq ent1 (cadddr val1))
      (command "LINE" pt1 glpt "")
      (setq lin1 (entlast))
      (setq obj1 (vlax-ename->vla-object lin1))
      (setq intcnt (CountUniqueIntersections obj1 selset (caddr glpt)))
      (if (and (<= intcnt 1) (not (equal frstelev elev1 0.01)))
(progn (setq found (1+ found))
       (setq frstelev elev1)
       (setq mySetpt2 (append mySetpt2 (list (list elev1 dist1))))
       (vla-delete obj1)
)
(progn (vla-delete obj1))
      )
      (if (= found 2)
(progn (setq lencnt (+ lenset 1)))
(progn (setq lencnt (1+ lencnt)))
      )
    )
    (if (= (length mySetpt2) 2)
      (progn (setq elev1 (car (car mySetpt2)))
     (setq dist1 (cadr (car mySetpt2)))
     (setq elev2 (car (cadr mySetpt2)))
     (setq dist2 (cadr (cadr mySetpt2)))
     (setq elev (+ (* (/ (- elev2 elev1) (+ dist2 dist1)) dist1) elev1))
      )
      (progn (setq elev (car (car mySetpt2))))
    )
    elev
  )
  (defun CountUniqueIntersections (obj1 sscont ht / cntb unlst ncont2 ncont2cnt entcont2 obj2 ui l)
    (setq cntb 0)
    (setq unlst (list))
    (setq ncont2 (sslength sscont))
    (setq ncont2cnt 0)
    (while (< ncont2cnt ncont2)
      (setq entcont2 (ssname sscont ncont2cnt))
      (setq obj2 (vlax-ename->vla-object entcont2))
      (setq ui (vla-get-elevation obj2))
      (vla-put-elevation obj2 ht)
      (if (setq l (vlax-invoke obj1 'intersectwith obj2 acExtendNone))
(setq unlst (append unlst (list (list l))))
      )
      (vla-put-elevation obj2 ui)
      (setq unlst (gc:distinctFuzz unlst 0.0001))
      (if (> (length unlst) 1)
(setq ncont2cnt (1+ ncont2))
(setq ncont2cnt (1+ ncont2cnt))
      )
    )
    (length unlst)
  )
;;;
;;;
;;;
  ;| ----------------------------------
            ACTUAL PROGRAM STARTED     
---------------------------------------
  |;
  (setq oldsnapmode (getvar "snapmode"))
  (setq oldosmode (getvar "osmode"))
  (setq oldlayer (getvar "clayer"))
  (setq oldorthomode (getvar "orthomode"))
  (if (not (tblsearch "LAYER" "TEMP1"))
    (command "_.-layer" "M" "TEMP1" "C" "1" "" "L" "Continuous" "" "LW" 0.05 "" "")
  )
  (setvar "clayer" "TEMP1")
  (prompt "\nSelect Contours")
  (if (setq ssc (ssget "_:L" '((0 . "*POLYLINE"))))
    (progn (setq app (vlax-get-acad-object))
   (setq fcnt 1)
   (while (setq glpt (getpoint "Select Point (or Enter to Exit) : "))
     (setq vext (CurrentZoomWindow))
     (setvar "cmdecho" 0)
     (setvar "snapmode" 0)
     (setvar "osmode" 0)
     (setvar "orthomode" 0)
     (setq elev (GetElevPoint glpt ssc))
     (entmake ;Start entity make
       (list ;Start list
(cons 0 "TEXT") ;Entity type
(cons 8 "ELEVATION") ;Layer name
(cons 10 glpt) ;Text first base point
(cons 11 glpt) ;Text second base point
(cons 40 3) ;Text height
(cons 1 (rtos elev 2 2)) ;Text string
(cons 50 0) ;Text rotation
(cons 41 1.0) ;Relative x scale factor
(cons 51 0.0) ;Oblique angle
(cons 7 "Standard") ;Text style
(cons 71 0) ;Text generation flag
(cons 72 1) ;Horizontal justification flag center
;(cons 11 TFBP) ;Text first base point
;(cons 210 EXDR) ;Extrusion direction (Needed for 3D)
(cons 73 2) ;Middle justification
       ) ;End list
     )
     (vla-zoomwindow app (vlax-3d-point (car vext)) (vlax-3d-point (cadr vext)))
   )
    )
  )
  (setvar "snapmode" oldsnapmode)
  (setvar "orthomode" oldorthomode)
  (setvar "osmode" oldosmode)
  (setvar "cmdecho" 1)
  (if (tblsearch "LAYER" oldlayer)
    (setvar "clayer" oldlayer)
  )
  (princ)
)




[Fabricio28]

My Code :

Code: [Select]

;;; This file writes Level of a point as per Selected Contours

(defun c:SpotElevfromContours ()
  (vl-load-com)
  ;;----------------
  ;; Functions
  ;;----------------
  (defun gc:distinctFuzz (lst fuzz)
    (if lst
      (cons (car lst) (gc:distinctFuzz (vl-remove-if '(lambda (x) (equal x (car lst) fuzz)) lst) fuzz))
    )
  )
  (defun CurrentZoomWindow (/ a b c d x)
    (setq b (getvar "viewsize")
  c (car (getvar "screensize"))
  d (cadr (getvar "screensize"))
  a (* b (/ c d))
  x (trans (getvar "viewctr") 1 2)
  c (list (- (car x) (/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0)
  d (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0)
  c (trans c 2 1)
  d (trans d 2 1)
    )
    (list c d)
  )
  (defun GetElevPoint (glpt sscont /   app    mind     elev     muSetpt1 mySetpt2 foundcontours rectsize increment     minx     miny     maxx     maxy pt1 pt2
       pt3 pt4 selset   ncont    entcont  ptcont   dd       fg       lenset lencnt found   val1    elev1    dist1    ent1     lin1     obj1 intcnt frstelev
       elev2 dist2
      )
    (setq app (vlax-get-acad-object))
    (setq mind 0)
    (setq elev "")
    (setq mySetpt1 (list))
    (setq mySetpt2 (list))
    (setq foundcontours 0)
    (setq rectsize 200.0)
    (setq increment 20.0)
    (while (eq foundcontours 0)
      (setq minx (- (car glpt) rectsize))
      (setq maxx (+ (car glpt) rectsize))
      (setq miny (- (cadr glpt) rectsize))
      (setq maxy (+ (cadr glpt) rectsize))
      (setq pt1 (list minx miny 0.0))
      (setq pt2 (list maxx miny 0.0))
      (setq pt3 (list maxx maxy 0.0))
      (setq pt4 (list minx maxy 0.0))
      (vla-zoomwindow app (vlax-3d-point pt1) (vlax-3d-point pt3))
      (if (setq selset (ACET-SS-INTERSECTION sscont (ssget "_CP" (list pt1 pt2 pt3 pt4) '((0 . "*POLYLINE")))))
(setq foundcontours 1)
      )
      (setq rectsize (+ rectsize increment))
    )
    (repeat (setq ncont (sslength selset))
      (setq entcont (ssname selset (setq ncont (1- ncont))))
      (setq elev (vla-get-elevation (vlax-ename->vla-object entcont)))
      (setq ptcont (vlax-curve-getclosestpointto entcont glpt))
      (setq ptcont (list (car ptcont) (cadr ptcont) (caddr glpt)))
      (setq dd (distance ptcont glpt))
      (setq mySetpt1 (append mySetpt1 (list (list elev dd ptcont entcont))))
    )
    (setq fg (vl-sort mySetpt1 '(lambda (e1 e2) (< (cadr e1) (cadr e2)))))
    (setq lenset (length fg))
    (setq lencnt 0)
    (setq found 0)
    (setq frstelev nil)
    (while (< lencnt lenset)
      (setq val1 (nth lencnt fg))
      (setq elev1 (car val1))
      (setq dist1 (cadr val1))
      (setq pt1 (caddr val1))
      (setq ent1 (cadddr val1))
      (command "LINE" pt1 glpt "")
      (setq lin1 (entlast))
      (setq obj1 (vlax-ename->vla-object lin1))
      (setq intcnt (CountUniqueIntersections obj1 selset (caddr glpt)))
      (if (and (<= intcnt 1) (not (equal frstelev elev1 0.01)))
(progn (setq found (1+ found))
       (setq frstelev elev1)
       (setq mySetpt2 (append mySetpt2 (list (list elev1 dist1))))
       (vla-delete obj1)
)
(progn (vla-delete obj1))
      )
      (if (= found 2)
(progn (setq lencnt (+ lenset 1)))
(progn (setq lencnt (1+ lencnt)))
      )
    )
    (if (= (length mySetpt2) 2)
      (progn (setq elev1 (car (car mySetpt2)))
     (setq dist1 (cadr (car mySetpt2)))
     (setq elev2 (car (cadr mySetpt2)))
     (setq dist2 (cadr (cadr mySetpt2)))
     (setq elev (+ (* (/ (- elev2 elev1) (+ dist2 dist1)) dist1) elev1))
      )
      (progn (setq elev (car (car mySetpt2))))
    )
    elev
  )
  (defun CountUniqueIntersections (obj1 sscont ht / cntb unlst ncont2 ncont2cnt entcont2 obj2 ui l)
    (setq cntb 0)
    (setq unlst (list))
    (setq ncont2 (sslength sscont))
    (setq ncont2cnt 0)
    (while (< ncont2cnt ncont2)
      (setq entcont2 (ssname sscont ncont2cnt))
      (setq obj2 (vlax-ename->vla-object entcont2))
      (setq ui (vla-get-elevation obj2))
      (vla-put-elevation obj2 ht)
      (if (setq l (vlax-invoke obj1 'intersectwith obj2 acExtendNone))
(setq unlst (append unlst (list (list l))))
      )
      (vla-put-elevation obj2 ui)
      (setq unlst (gc:distinctFuzz unlst 0.0001))
      (if (> (length unlst) 1)
(setq ncont2cnt (1+ ncont2))
(setq ncont2cnt (1+ ncont2cnt))
      )
    )
    (length unlst)
  )
;;;
;;;
;;;
  ;| ----------------------------------
            ACTUAL PROGRAM STARTED     
---------------------------------------
  |;
  (setq oldsnapmode (getvar "snapmode"))
  (setq oldosmode (getvar "osmode"))
  (setq oldlayer (getvar "clayer"))
  (setq oldorthomode (getvar "orthomode"))
  (if (not (tblsearch "LAYER" "TEMP1"))
    (command "_.-layer" "M" "TEMP1" "C" "1" "" "L" "Continuous" "" "LW" 0.05 "" "")
  )
  (setvar "clayer" "TEMP1")
  (prompt "\nSelect Contours")
  (if (setq ssc (ssget "_:L" '((0 . "*POLYLINE"))))
    (progn (setq app (vlax-get-acad-object))
   (setq fcnt 1)
   (while (setq glpt (getpoint "Select Point (or Enter to Exit) : "))
     (setq vext (CurrentZoomWindow))
     (setvar "cmdecho" 0)
     (setvar "snapmode" 0)
     (setvar "osmode" 0)
     (setvar "orthomode" 0)
     (setq elev (GetElevPoint glpt ssc))
     (entmake ;Start entity make
       (list ;Start list
(cons 0 "TEXT") ;Entity type
(cons 8 "ELEVATION") ;Layer name
(cons 10 glpt) ;Text first base point
(cons 11 glpt) ;Text second base point
(cons 40 3) ;Text height
(cons 1 (rtos elev 2 2)) ;Text string
(cons 50 0) ;Text rotation
(cons 41 1.0) ;Relative x scale factor
(cons 51 0.0) ;Oblique angle
(cons 7 "Standard") ;Text style
(cons 71 0) ;Text generation flag
(cons 72 1) ;Horizontal justification flag center
;(cons 11 TFBP) ;Text first base point
;(cons 210 EXDR) ;Extrusion direction (Needed for 3D)
(cons 73 2) ;Middle justification
       ) ;End list
     )
     (vla-zoomwindow app (vlax-3d-point (car vext)) (vlax-3d-point (cadr vext)))
   )
    )
  )
  (setvar "snapmode" oldsnapmode)
  (setvar "orthomode" oldorthomode)
  (setvar "osmode" oldosmode)
  (setvar "cmdecho" 1)
  (if (tblsearch "LAYER" oldlayer)
    (setvar "clayer" oldlayer)
  )
  (princ)
)




Wow!!!
Perfect mailmaverick

Worked like a charm!!

[mailmaverick]

Happy to help.

Whatvever LISP I have learnt, full credit goes to this forum and its members such as LEE MAC, CAB, RONJONP, BLACKBOX, JOHN KAUL, ALANJT and many more. Sorry if i missed some names.