Author Topic: convert 2d polyline to 3d polyline from contours  (Read 350 times)

0 Members and 1 Guest are viewing this topic.

Topographer

  • Bull Frog
  • Posts: 498
convert 2d polyline to 3d polyline from contours
« on: November 22, 2017, 01:01:16 pm »
Hi ,this lisp code convert lines to 3d polylines from contours .I need this code to convert lines and polylines to 3d polylines from contours. Can any one help?

the names of the  layers of the contous is

Contour Major Natural Ground color 72
Contour Minor Natural Ground color 23

Code - Auto/Visual Lisp: [Select]
  1. ;Drapes a 3dpolyline over polylines along a selected line.
  2. (defun c:sample-pl ( / li *ModSpc *ActDoc *Acad lobj p1 p2 ss sslen i plobj pnts n li pntli finli var)
  3.  (setq li nil)
  4.  (setq *ModSpc (vlax-get-property (setq *ActDoc (vlax-get-property (setq *acad (vlax-get-acad-object)) 'ActiveDocument)) 'ModelSpace))
  5.  (setq lobj (vlax-ename->vla-object (car (entsel "\nSelect Line Object: "))))
  6.  (setq p1 (vlax-safearray->list (vlax-variant-value (vlax-get-property lobj 'StartPoint))))
  7.  (setq p2 (vlax-safearray->list (vlax-variant-value (vlax-get-property lobj 'EndPoint))))
  8.  (setq ss (ssget "f" (list p1 p2) '(( 0 . "LWPOLYLINE"))))
  9.  (setq sslen (sslength ss))
  10.  (setq i 0)
  11.  (repeat sslen
  12.    (setq plobj (vlax-ename->vla-object (ssname ss i)))
  13.    (setq el (vlax-get-property plobj 'Elevation))
  14.    (vlax-put-property plobj 'Elevation 0)
  15.    (setq pnts (vlax-invoke lobj 'IntersectWith plobj acExtendNone))
  16.    (vlax-put-property plobj 'Elevation el)
  17.    (vlax-release-object plobj)
  18.    (setq n 0)
  19.    (repeat (/ (length pnts) 3)
  20.      (setq li (append li (list (nth (+ n 0) pnts))))
  21.      (setq li (append li (list (nth (+ n 1) pnts))))
  22.      (setq li (append li (list el)))
  23.      (drxc (list (nth (+ n 0) pnts) (nth (+ n 1) pnts) el) 2)
  24.      (setq n (+ n 3))
  25.      )
  26.    (setq i (1+ i))
  27.    )
  28.  (setq n 0)
  29.  (setq pntli nil)
  30.  (repeat (/ (length li) 3)
  31.    (setq pntli (append pntli (list (cons (distance (list (nth (+ n 0) li) (nth (+ n 1) li)) (list (nth 0 p1) (nth 1 p1))) (list (list (nth (+ n 0) li) (nth (+ n 1) li)(nth (+ n 2) li)))))))
  32.    (setq n (+ n 3))
  33.    )
  34.  (setq pntli (vl-sort pntli (function (lambda (d1 d2) (< (car d1) (car d2))))))
  35.  (setq n 0)
  36.  (setq finli nil)
  37.  (repeat (length pntli)
  38.    (setq finli (append finli (cadr (nth n pntli))))
  39.    (setq n (1+ n))
  40.  )
  41.  (setq var (pl->var finli))
  42.  (setq 3dobj2 (vlax-invoke-method *ModSpc 'Add3DPoly var))
  43.  (vlax-put-property 3dobj2 'Color 1)
  44.  )
  45.  
  46.  
  47. ;Given Pointlist returns pointlist in variant form
  48. (defun PL->VAR ( pl / pl ub sa var)
  49.  (setq ub (- (length pl) 1))
  50.  (setq sa (vlax-make-safearray vlax-vbdouble (cons 0 ub)))
  51.  (setq var (vlax-make-variant (setq sa (vlax-safearray-fill sa pl))))
  52.  )
  53.  
  54. ;Graphically at given point and color Example (drxc '( 1 2 3) 1) draws x at x=1 y=2 z=3 in the color red
  55. (defun drxc (ctr color / vs xs xs2 cor1 cor2 cor3 cor4 ctr color)
  56.  (setq vs (getvar "viewsize"))
  57.  (setq xs (/ vs 20))
  58.  (setq xs2 (/ xs 2))
  59.  (setq cor1 (polar ctr (* pi 0.25) xs2))
  60.  (setq cor2 (polar ctr (* pi 0.75) xs2))
  61.  (setq cor3 (polar ctr (* pi 1.25) xs2))
  62.  (setq cor4 (polar ctr (* pi 1.75) xs2))
  63.  (grdraw ctr cor1 color 0)
  64.  (grdraw ctr cor2 color 0)
  65.  (grdraw ctr cor3 color 0)
  66.  (grdraw ctr cor4 color 0)
  67.  )
  68.  
  69.  
  70. ;The following was written by LEE MAC ~ Cadtutor
  71. ;in response to my posting of the above code.
  72. (defun c:LWPolySample ( / _dxf doc spc lobj p1 ss ev tmp lst ) (vl-load-com)
  73.  ;; Lee Mac 2010
  74.  
  75.  (defun _dxf ( code entity ) (cdr (assoc code (entget entity))))
  76.  
  77.  (LM:ActiveSpace 'doc 'spc)
  78.  (COMMAND "_layer" "_m" "3d section" "_c" "55" "" "" "")
  79.  (if
  80.    (and (setq lobj (car (entsel "\n&#917;&#960;&#953;&#955;&#941;&#958;&#964;&#949; &#956;&#953;&#945; &#947;&#961;&#945;&#956;&#956;&#942;: "))) (eq "LINE" (_dxf 0 lobj))
  81.      (ssget "_F"
  82.        (list (setq p1 (_dxf 10 lobj)) (_dxf 11 lobj)) '((0 . "LWPOLYLINE"))
  83.      )
  84.    )
  85.    (progn (setq lobj (vlax-ename->vla-object lobj))
  86.  
  87.      (vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))
  88.  
  89.        (setq ev (vla-get-Elevation obj))
  90.        (vla-put-Elevation obj 0.0)
  91.  
  92.        (setq lst
  93.          (cons
  94.            (mapcar
  95.              (function
  96.                (lambda ( x ) (list (car x) (cadr x) ev))
  97.              )
  98.              (GroupByNum (vlax-invoke obj 'IntersectWith lobj acExtendNone) 3)
  99.            )
  100.            lst
  101.          )
  102.        )
  103.        (vla-put-Elevation obj ev)
  104.      )
  105.      (vla-delete ss)
  106.  
  107.      (vla-put-Color
  108.        (vlax-invoke spc 'Add3DPoly
  109.          (apply 'append
  110.            (vl-sort (apply 'append lst)
  111.             '(lambda ( a b )
  112.                (< (distance p1 (list (car a) (cadr a))) (distance p1 (list (car b) (cadr b))))
  113.              )
  114.            )
  115.          )
  116.        )
  117.      )
  118.    )
  119.  )
  120.  
  121.  (princ)
  122. )
  123.  
  124. (defun GroupByNum ( l n / r)
  125.  ;; Lee Mac 2010
  126.  (setq r (list (car l)))
  127.  
  128.  (if l
  129.    (cons
  130.      (reverse
  131.        (repeat (1- n) (setq l (cdr l) r (cons (car l) r)))
  132.      )
  133.      (GroupByNum (cdr l) n)
  134.    )
  135.  )
  136. )
  137.  
  138. ;;--------------------=={ ActiveSpace }==---------------------;;
  139. ;;                                                            ;;
  140. ;;  Retrieves pointers to the Active Document and Space       ;;
  141. ;;------------------------------------------------------------;;
  142. ;;  Author: Lee Mac, Copyright 2010 - www.lee-mac.com       ;;
  143. ;;------------------------------------------------------------;;
  144. ;;  Arguments:                                                ;;
  145. ;;  *doc - quoted symbol (other than *doc)                    ;;
  146. ;;  *spc - quoted symbol (other than *spc)                    ;;
  147. ;;------------------------------------------------------------;;
  148.  
  149. (defun LM:ActiveSpace ( *doc *spc )
  150.  ;; Lee Mac 2010
  151.  (set *spc
  152.      (set *doc
  153.          (vlax-get-acad-object)
  154.        )
  155.      )
  156.      (if (= 1 (getvar 'CVPORT)) 'PaperSpace 'ModelSpace)
  157.    )
  158.  )
  159. )
  160.  
  161.  

thanks


Topographer

  • Bull Frog
  • Posts: 498
Re: convert 2d polyline to 3d polyline from contours
« Reply #2 on: November 23, 2017, 01:37:29 am »
thank you

mailmaverick

  • Bull Frog
  • Posts: 376
Re: convert 2d polyline to 3d polyline from contours
« Reply #3 on: November 24, 2017, 05:22:52 am »
Dear Topographer, please let me know what is the use of having a 3D polyline with every vertex at same elevation (Z value) as compared to a 2D Polyline with elevation ?

Topographer

  • Bull Frog
  • Posts: 498
Re: convert 2d polyline to 3d polyline from contours
« Reply #4 on: November 24, 2017, 08:29:40 am »
i am using it to draw cross sections

Topographer

  • Bull Frog
  • Posts: 498
Re: convert 2d polyline to 3d polyline from contours
« Reply #5 on: November 26, 2017, 05:19:03 am »
Hi ribarm i use your code and works fine . As i said in the first post the names of the contour layers is Contour Major Natural Ground color 72 and Contour Minor Natural Ground color 23 , and the contours is LWPOLYLINE. Is it possible to understand the contours without need to delect them?

Code - Auto/Visual Lisp: [Select]
  1. (defun c:pl3dpl ;fencelwpoly23dpolyelevations
  2.  ( / *error* bbucs ucsf osm cec ss1 ss2 i lw pl sss ssl sspl e )
  3.  
  4.  
  5.  (defun *error* ( msg )
  6.    (if ucsf
  7.      (command "_.UCS" "_P")
  8.    )
  9.    (command "_.ZOOM" "_P")
  10.    (if osm
  11.      (setvar 'osmode osm)
  12.    )
  13.    (if cec
  14.      (setvar 'cecolor cec)
  15.    )
  16.    (if msg
  17.      (prompt msg)
  18.    )
  19.    (princ)
  20.  )
  21.  
  22.  (defun bbucs ( ss / UCS2WCSMatrix WCS2UCSMatrix n ent minpt maxpt minptlst maxptlst minptbbx minptbby minptbbz minptbb maxptbbx maxptbby maxptbbz maxptbb )
  23.  
  24.    (vl-load-com)
  25.  
  26.    ;; Doug C. Broad, Jr.
  27.    ;; can be used with vla-transformby to
  28.    ;; transform objects from the UCS to the WCS
  29.    (defun UCS2WCSMatrix ()
  30.      (vlax-tmatrix
  31.        (append
  32.          (mapcar
  33.           '(lambda (vector origin)
  34.            (append (trans vector 1 0 t) (list origin))
  35.          )
  36.          (list '(1 0 0) '(0 1 0) '(0 0 1))
  37.          (trans '(0 0 0) 0 1)
  38.          )
  39.          (list '(0 0 0 1))
  40.        )
  41.      )
  42.    )
  43.    ;; transform objects from the WCS to the UCS
  44.    (defun WCS2UCSMatrix ()
  45.      (vlax-tmatrix
  46.        (append
  47.          (mapcar
  48.           '(lambda (vector origin)
  49.            (append (trans vector 0 1 t) (list origin))
  50.          )
  51.          (list '(1 0 0) '(0 1 0) '(0 0 1))
  52.          (trans '(0 0 0) 1 0)
  53.          )
  54.          (list '(0 0 0 1))
  55.        )
  56.      )
  57.    )
  58.  
  59.    (if ss
  60.      (progn
  61.        (repeat (setq n (sslength ss))
  62.          (setq ent (ssname ss (setq n (1- n))))
  63.          (vla-TransformBy (vlax-ename->vla-object ent) (UCS2WCSMatrix))
  64.          (vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
  65.          (vla-TransformBy (vlax-ename->vla-object ent) (WCS2UCSMatrix))
  66.          (setq minpt (vlax-safearray->list minpoint))
  67.          (setq maxpt (vlax-safearray->list maxpoint))
  68.          (setq minptlst (cons minpt minptlst))
  69.          (setq maxptlst (cons maxpt maxptlst))
  70.        )
  71.        (setq minptbbx (caar (vl-sort minptlst '(lambda (a b) (< (car a) (car b))))))
  72.        (setq minptbby (cadar (vl-sort minptlst '(lambda (a b) (< (cadr a) (cadr b))))))
  73.        (setq minptbbz (caddar (vl-sort minptlst '(lambda (a b) (< (caddr a) (caddr b))))))
  74.        (setq maxptbbx (caar (vl-sort maxptlst '(lambda (a b) (> (car a) (car b))))))
  75.        (setq maxptbby (cadar (vl-sort maxptlst '(lambda (a b) (> (cadr a) (cadr b))))))
  76.        (setq maxptbbz (caddar (vl-sort maxptlst '(lambda (a b) (> (caddr a) (caddr b))))))
  77.        (setq minptbb (list minptbbx minptbby minptbbz))
  78.        (setq maxptbb (list maxptbbx maxptbby maxptbbz))
  79.      )
  80.    )
  81.    (list minptbb maxptbb)
  82.  )
  83.  
  84.  (if (= 0 (getvar 'worlducs))
  85.    (progn
  86.      (command "_.UCS" "_W")
  87.      (command "_.PLAN" "")
  88.      (setq ucsf t)
  89.    )
  90.    (command "_.PLAN" "")
  91.  )
  92.  (setq osm (getvar 'osmode))
  93.  (setvar 'osmode 0)
  94.  (setq cec (getvar 'cecolor))
  95.  (setvar 'cecolor "3")
  96.  (prompt "\nSelect OPEN \"STRAIGHT\" LWPOLYLINES that lie in plane parallel to WCS - PROJECTION LWPOLYLINES (NOT ELEVATION)...")
  97.  (setq ss1 (ssget (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(70 . 0) '(70 . 128) '(-4 . "or>") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>") '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
  98.  (while (or
  99.           (not ss1)
  100.           (vl-every '(lambda ( x ) (not (equal (caddar (bbucs (ssadd x))) (caddr (cadr (bbucs (ssadd x)))) 1e-6))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1))))
  101.         )
  102.    (prompt "\nEmpty sel.set... Please reselect again...")
  103.    (setq ss1 (ssget (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(70 . 0) '(70 . 128) '(-4 . "or>") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>") '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
  104.  )
  105.  (prompt "\nSelect LWPOLYLINES that lie in plane parallel to WCS - ELEVATION LWPOLYLINES (NOT PROJECTION)...")
  106.  (setq ss2 (ssget (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>"))))
  107.  (while (not ss2)
  108.    (prompt "\nEmpty sel.set... Please reselect again...")
  109.    (setq ss2 (ssget (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>"))))
  110.  )
  111.  (repeat (setq i (sslength ss1))
  112.    (setq lw (ssname ss1 (setq i (1- i))))
  113.    (setq pl (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget lw))))
  114.    (setq sss (ssget "_F" pl (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>"))))
  115.    (setq ssl (ssnamex sss))
  116.    (setq ssl (vl-remove-if '(lambda ( x ) (eq (cadr x) lw)) ssl))
  117.    (setq sspl (mapcar 'cadr (apply 'append (mapcar '(lambda ( x ) (vl-remove-if-not 'listp x)) ssl))))
  118.    (setq sspl (vl-sort sspl '(lambda ( a b ) (< (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (list (car a) (cadr a) (cdr (assoc 38 (entget lw)))))) (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (list (car b) (cadr b) (cdr (assoc 38 (entget lw))))))))))
  119.    (command "_.3DPOLY")
  120.    (foreach p sspl
  121.      (if (vl-some '(lambda ( x ) (if (vlax-curve-getparamatpoint x (list (car p) (cadr p) (cdr (assoc 38 (entget x))))) (setq e x))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
  122.        (command "_non" (list (car p) (cadr p) (cdr (assoc 38 (entget e)))))
  123.      )
  124.    )
  125.    (command "")
  126.  )
  127.  (*error* nil)
  128. )
  129.  

Thanks

Topographer

  • Bull Frog
  • Posts: 498
Re: convert 2d polyline to 3d polyline from contours
« Reply #6 on: November 28, 2017, 02:13:21 am »
Hi ribarm. I did this change in the code but didn't work

Code - Auto/Visual Lisp: [Select]
  1. ;(prompt "\nSelect LWPOLYLINES that lie in plane parallel to WCS - ELEVATION LWPOLYLINES (NOT PROJECTION)...")
  2.  ;(setq ss2 (ssget (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>"))))
  3. ; (while (not ss2)
  4.  ;  (prompt "\nEmpty sel.set... Please reselect again...")
  5. ;   (setq ss2 (ssget (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>"))))
  6. ; )
  7.    (setq sss (ssget "_F" pl (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(Contour Major Natural Ground) '(Contour Minor Natural Ground) '(-4 . "or>"))))
  8.  

Any ideas . Thanks

Topographer

  • Bull Frog
  • Posts: 498
Re: convert 2d polyline to 3d polyline from contours
« Reply #7 on: November 29, 2017, 11:08:08 am »
Any ideas?. Thanks