convert 2d polyline to 3d polyline from contours

Hi. I have a little problem and i need some help. I want to convert some 2d polylines to 3d polyline using the elevetion of the contours.

I am searching fot a lisp to select a 2d polyline and convert it to 3d using contours elevetions

Thanks

test1.dwg

See if this can help you, it's little dummy, but I can do it...

(defun continue ( / sscurve ) (vl-load-com)
 (if (null el) (setq el (entlast)))
 (prompt "\nSelect curve you want to project on tin surface...")
 (setq sscurve (ssget "_+.:E:S:L"))
 (while (or (not sscurve) (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getstartparam (list (ssname sscurve 0)))))
   (prompt "\nEmpty sel.set or selected entity doesn't belong to curves...")
   (setq sscurve (ssget "_+.:E:S:L"))
 )
 (princ)
)

(defun finish ( / l-join ell )

 (defun l-join ( ell / ss sss k ent stpt enpt septs chkduppt septn stent ptlst nxtentst nxtenten ellss )
   (if (vl-every '(lambda ( x ) (eq (cdr (assoc 0 (entget x))) "LINE")) ell)
     (progn
       (setq ss (ssadd))
       (foreach l ell
         (ssadd l ss)
       )
       (setq sss (ssadd))
       (repeat (setq k (sslength ss))
         (setq ent (ssname ss (setq k (1- k))))
         (ssadd ent sss)
       )    
       (repeat (setq k (sslength ss))
         (setq ent (ssname ss (setq k (1- k))))
         (setq stpt (cdr (assoc 10 (entget ent))))
         (setq enpt (cdr (assoc 11 (entget ent))))
         (setq septs (cons stpt septs))
         (setq septs (cons enpt septs))
       )
       (setq sept septs)
       (defun chkduppt (pt lst / chk)
         (foreach ptt lst
           (if (equal pt ptt 1e-6) (setq chk (cons T chk)))
         )
         chk
       )
       (foreach pt septs
         (if (eq (length (chkduppt pt septs)) 2) (setq septn (cons pt septn)))
       )
       (foreach pt septn
         (setq sept (vl-remove pt sept))
       )
       (if (eq sept nil) (setq sept (acet-list-remove-duplicates septs 1e-6)))
       (repeat (setq k (sslength ss))
         (setq ent (ssname ss (setq k (1- k))))
         (setq stpt (cdr (assoc 10 (entget ent))))
         (if (equal stpt (car sept) 1e-6) (setq stent ent))
       )
       (if (eq stent nil)
         (repeat (setq k (sslength ss))
           (setq ent (ssname ss (setq k (1- k))))
           (setq enpt (cdr (assoc 11 (entget ent))))
           (if (equal enpt (car sept) 1e-6) (setq enent ent))
         )
       )
       (if stent
       (progn
         (setq ptlst (cons (cdr (assoc 10 (entget stent))) ptlst))
         (setq ptlst (cons (cdr (assoc 11 (entget stent))) ptlst))
         (setq enpt (cdr (assoc 11 (entget stent))))
         (ssdel stent ss)
       )
       (progn
         (setq ptlst (cons (cdr (assoc 11 (entget enent))) ptlst))
         (setq ptlst (cons (cdr (assoc 10 (entget enent))) ptlst))
         (setq enpt (cdr (assoc 10 (entget enent))))
         (ssdel enent ss)
       )
       )
       (while (/= (sslength ss) 0)
         (setq nxtentst nil)
         (setq nxtenten nil)
         (repeat (setq k (sslength ss))
           (setq ent (ssname ss (setq k (1- k))))
           (setq stpt (cdr (assoc 10 (entget ent))))
           (if (equal enpt stpt 1e-6) (setq nxtentst ent))
         )
         (if nxtentst nil
           (repeat (setq k (sslength ss))
             (setq ent (ssname ss (setq k (1- k))))
             (setq enptt (cdr (assoc 11 (entget ent))))
             (if (equal enpt enptt 1e-6) (setq nxtenten ent))
           )
         )
         (if nxtentst
         (progn
           (setq ptlst (cons (cdr (assoc 10 (entget nxtentst))) ptlst))
           (setq ptlst (cons (cdr (assoc 11 (entget nxtentst))) ptlst))
           (setq enpt (cdr (assoc 11 (entget nxtentst))))
           (ssdel nxtentst ss)
         )
         (progn
           (setq ptlst (cons (cdr (assoc 11 (entget nxtenten))) ptlst))
           (setq ptlst (cons (cdr (assoc 10 (entget nxtenten))) ptlst))
           (setq enpt (cdr (assoc 10 (entget nxtenten))))
           (ssdel nxtenten ss)
         )
         )
       )
       (setq ptlst (acet-list-remove-duplicates ptlst 1e-6))
       (command "_.3DPOLY")
       (foreach pt ptlst
         (command "_non" pt)
       )
       (command "")
       (setq el (entlast))
       (while (eq (cdr (assoc 0 (entget (setq el (entnext el))))) "VERTEX"))
       (foreach l ell
         (entdel l)
       )
     )
     (progn
       (setq ellss (ssadd))
       (foreach l ell
         (ssadd l ellss)
       )
       (foreach l ell
         (command "_.JOIN" l ellss "")
       )
       (setq el (entlast))
     )
   )
 )

 (while (setq el (entnext el))
   (setq ell (cons el ell))
 )
 (l-join ell)
 (princ)
)

(defun c:projcurvestotin nil
 (prompt "\nSelect tin surface made of 3D FACES...")
 (while (not (ssget "_:L" '((0 . "3DFACE"))))
   (prompt "\nEmpty sel.set... Please select TIN surface again...")
   (ssget "_:L" '((0 . "3DFACE")))
 )
 (command "_MESHSMOOTH")
 (prompt "\nType \"P\", then hit ENTER twicely and after that type \"UNION\" and select tin surface again, choose 3rd option, \nthen type \"(continue)\" and after that type \"PROJECTGEOMETRY\", then type \"P\", hit ENTER, then click on TIN surface and choose \"UCS\", \nand at the end type \"(finish)\"; Repeat steps from \"(continue)\" as much as you have curves you want to project...")
 (textscr)
 (princ)
)

marko_ribar thank you for the reply. I test your code but i have this error.

1) i wrire projcurvestotin

2) i select all the 3d faces

3)i write p (and select the 2d polylines)

4) gives me the error !!!

I am assuming that you wish to, in effect, drape a line over the 2d contours that you have and create a 3d polyline.

I wrote this code a while back. It also includes code written by Lee Mac in response to the code I posted.

;Drapes a 3dpolyline over polylines along a selected line. 
(vl-load-com)
(defun c:sample-pl ( / li *ModSpc *ActDoc *Acad lobj p1 p2 ss sslen i plobj pnts n li pntli finli var)
 (setq li nil)
 (setq *ModSpc (vlax-get-property (setq *ActDoc (vlax-get-property (setq *acad (vlax-get-acad-object)) 'ActiveDocument)) 'ModelSpace))
 (setq lobj (vlax-ename->vla-object (car (entsel "\nSelect Line Object: "))))
 (setq p1 (vlax-safearray->list (vlax-variant-value (vlax-get-property lobj 'StartPoint))))
 (setq p2 (vlax-safearray->list (vlax-variant-value (vlax-get-property lobj 'EndPoint))))
 (setq ss (ssget "f" (list p1 p2) '(( 0 . "LWPOLYLINE"))))
 (setq sslen (sslength ss))
 (setq i 0)
 (repeat sslen
   (setq plobj (vlax-ename->vla-object (ssname ss i)))
   (setq el (vlax-get-property plobj 'Elevation))
   (vlax-put-property plobj 'Elevation 0)
   (setq pnts (vlax-invoke lobj 'IntersectWith plobj acExtendNone))
   (vlax-put-property plobj 'Elevation el)
   (vlax-release-object plobj)
   (setq n 0)
   (repeat (/ (length pnts) 3)
     (setq li (append li (list (nth (+ n 0) pnts))))
     (setq li (append li (list (nth (+ n 1) pnts))))
     (setq li (append li (list el)))
     (drxc (list (nth (+ n 0) pnts) (nth (+ n 1) pnts) el) 2)
     (setq n (+ n 3))
     )
   (setq i (1+ i))
   )
 (setq n 0)
 (setq pntli nil)
 (repeat (/ (length li) 3)
   (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)))))))
   (setq n (+ n 3))
   )
 (setq pntli (vl-sort pntli (function (lambda (d1 d2) (< (car d1) (car d2))))))
 (setq n 0)
 (setq finli nil)
 (repeat (length pntli)
   (setq finli (append finli (cadr (nth n pntli))))
   (setq n (1+ n))
 )
 (setq var (pl->var finli))
 (setq 3dobj2 (vlax-invoke-method *ModSpc 'Add3DPoly var))
 (vlax-put-property 3dobj2 'Color 1)
 (vlax-release-object 3dobj2)
 )


;Given Pointlist returns pointlist in variant form
(defun PL->VAR ( pl / pl ub sa var)
 (setq ub (- (length pl) 1))
 (setq sa (vlax-make-safearray vlax-vbdouble (cons 0 ub)))
 (setq var (vlax-make-variant (setq sa (vlax-safearray-fill sa pl))))
 )

;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 			
(defun drxc (ctr color / vs xs xs2 cor1 cor2 cor3 cor4 ctr color)
 (setq vs (getvar "viewsize"))
 (setq xs (/ vs 20))
 (setq xs2 (/ xs 2))
 (setq cor1 (polar ctr (* pi 0.25) xs2))
 (setq cor2 (polar ctr (* pi 0.75) xs2))
 (setq cor3 (polar ctr (* pi 1.25) xs2))
 (setq cor4 (polar ctr (* pi 1.75) xs2))
 (grdraw ctr cor1 color 0)
 (grdraw ctr cor2 color 0)
 (grdraw ctr cor3 color 0)
 (grdraw ctr cor4 color 0)
 )


;The following was written by LEE MAC ~ Cadtutor
;in response to my posting of the above code.
(defun c:LWPolySample ( / _dxf doc spc lobj p1 ss ev tmp lst ) (vl-load-com)
 ;; © Lee Mac 2010

 (defun _dxf ( code entity ) (cdr (assoc code (entget entity))))

 (LM:ActiveSpace 'doc 'spc)
 
 (if
   (and (setq lobj (car (entsel "\nSelect Line: "))) (eq "LINE" (_dxf 0 lobj))
     (ssget "_F"
       (list (setq p1 (_dxf 10 lobj)) (_dxf 11 lobj)) '((0 . "LWPOLYLINE"))
     )
   )
   (progn (setq lobj (vlax-ename->vla-object lobj))
     
     (vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))

       (setq ev (vla-get-Elevation obj))
       (vla-put-Elevation obj 0.0)

       (setq lst
         (cons
           (mapcar
             (function
               (lambda ( x ) (list (car x) (cadr x) ev))
             )
             (GroupByNum (vlax-invoke obj 'IntersectWith lobj acExtendNone) 3)
           )
           lst
         )
       )
       (vla-put-Elevation obj ev)
     )
     (vla-delete ss)

     (vla-put-Color
       (vlax-invoke spc 'Add3DPoly
         (apply 'append
           (vl-sort (apply 'append lst)
            '(lambda ( a b )
               (< (distance p1 (list (car a) (cadr a))) (distance p1 (list (car b) (cadr b))))
             )
           )
         )
       )
       1
     )
   )
 )

 (princ)
)

(defun GroupByNum ( l n / r)
 ;; © Lee Mac 2010
 (setq r (list (car l)))
 
 (if l
   (cons
     (reverse
       (repeat (1- n) (setq l (cdr l) r (cons (car l) r)))
     )
     (GroupByNum (cdr l) n)
   )
 )
)

;;--------------------=={ ActiveSpace }==---------------------;;
;;                                                            ;;
;;  Retrieves pointers to the Active Document and Space       ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2010 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  *doc - quoted symbol (other than *doc)                    ;;
;;  *spc - quoted symbol (other than *spc)                    ;;
;;------------------------------------------------------------;;

(defun LM:ActiveSpace ( *doc *spc )
 ;; © Lee Mac 2010
 (set *spc
   (vlax-get-property
     (set *doc
       (vla-get-ActiveDocument
         (vlax-get-acad-object)
       )
     )
     (if (= 1 (getvar 'CVPORT)) 'PaperSpace 'ModelSpace)
   )
 )
)

Hi Hippe013 . How this lisp run?

Hippe013 I have all ready 3d contours .Over them i have 2d polylines.I want to convert the 2d polylines to 3d polylines using the elevetion of the contours.

Have you run the lisp?

Do you know how to run the lisp?

This code drapes a line over your contours and creates a 3dpolyline. Is this not what you were asking for? Replace the 2d polylines (yellow in your drawing) with a line. Run the code provided. Select the line and you will see a 3dpolyline draped over your contours.

If this is not what you are looking for then maybe you need to be more clear as to your request.

regards,

hippe013

Hippe013 now uderstand how to run your lisp. I type LWPOLYSAMPLE and select a line and convert it to polyline.

I want to add the 3d polyline to a layer.Can you tell me were to add this layer command

(command "_layer" "m" "3d polyline" "c" "3" "" "")

Thanks

I've fixed my code a little... I don't know, I can do it as I explained inside routine... I have tested it on A2014 and it should work and with 3d curve entities, not just lines or plines...

Try it once again as I've changed subfunctions to be independent of main function...

If you wish to add the 3dpolyline to a certain layer. Then (using my code c:sample-pl) make the following edit.

(vlax-put-property 3dobj2 'Color 1)
[color="red"](vlax-put-property 3dobj2 'Layer "WHATEVER-LAYER-YOU-WANT")[/color]
(vlax-release-object 3dobj2)

This will error out if the layer does not already exist.

In which case:

(setq lays (vlax-get-property (vlax-get-property (vlax-get-acad-object) 'ActiveDocument) 'Layers))
;This gets you to the layers collection

(setq n-layer (vlax-invoke-method lays 'Add "MyNewLayer"))
;This adds a new layer to the layer collection

I hope this helps.

P.S. I would recommend making your edits using VLIDE (The visual lisp editor).

marko_ribar I don't know. I am using autocad 2010. I try your code again but nothing happend ...

Seeing your picture, I can tell you that it's not an error... This is procedure before projecting on TIN, you should create MESHes from 3DFACEs, and then UNION them to be unique SURFACE... Then you should type (continue), select curve - line, pline, 2d or 3d curve, then you should use PROJECTGEOMETRY command and project curve to TIN surface, and at the end to connect those 3d lines or 3d curves that now lie on TIN surface, you should just type (finish)... Then you should repeat steps from (continue)... Repeat as many times as you have curves to be projected...

BTW... I don't know if A2010 have PROJECTGEOMETRY command, so maybe Hippe's code is better... You should use my if you have A2012,2013,2014,2015...

I've tested it on A2009 and it works fine, just check again the code was updated once again...

marko_ribar after the union the lisp stop.

Hippe013 i confiused with all this lines of code. I want when i select the line toy convert it to 3d polyline and create a layer with name (for example 3d polyline )

I all the times use this command

(command "_layer" "m" "3d polyline" "c" "3" "" "")

can you update your code please?

thanks

Ok i fix the layers thank you all for the help

See my note in post #12 and use my updated code in post #2...

Regards, M.R.

If nothing, you can try this improved version... Just 3 steps no matter how many curves you want to project to TIN... But I post new code here in case I need old one... I tested it on A2014, but should work also good and on A2009+...

(vl-load-com)

(defun continue ( / sscurves i curve tin ss el elll )
 (if (null el) (setq el (entlast)))
 (prompt "\nSelect curves you want to project on tin surface...")
 (setq sscurves (ssget "_:L"))
 (while (or (not sscurves) (vl-some '(lambda ( x ) (eq x T)) (mapcar '(lambda ( x ) (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getstartparam (list x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscurves))))))
   (prompt "\nEmpty sel.set or some selected entities doesn't belong to curves...")
   (setq sscurves (ssget "_:L"))
 )
 (setq tin el)
 (repeat (setq i (sslength sscurves))
   (setq curve (ssname sscurves (setq i (1- i))))
   (command "_PROJECTGEOMETRY" curve "" tin "U")
   (finish)
 )
 (setq ss (ssadd))
 (foreach e elll
   (ssadd e ss)
 )
 (sssetfirst nil ss)
 (ssget "_I")
 (princ)
)

(defun finish ( / l-join ell )

 (defun l-join ( ell / ss sss k ent stpt enpt septs chkduppt septn stent ptlst nxtentst nxtenten ellss )
   (if (vl-every '(lambda ( x ) (eq (cdr (assoc 0 (entget x))) "LINE")) ell)
     (progn
       (setq ss (ssadd))
       (foreach l ell
         (ssadd l ss)
       )
       (setq sss (ssadd))
       (repeat (setq k (sslength ss))
         (setq ent (ssname ss (setq k (1- k))))
         (ssadd ent sss)
       )    
       (repeat (setq k (sslength ss))
         (setq ent (ssname ss (setq k (1- k))))
         (setq stpt (cdr (assoc 10 (entget ent))))
         (setq enpt (cdr (assoc 11 (entget ent))))
         (setq septs (cons stpt septs))
         (setq septs (cons enpt septs))
       )
       (setq sept septs)
       (defun chkduppt (pt lst / chk)
         (foreach ptt lst
           (if (equal pt ptt 1e-6) (setq chk (cons T chk)))
         )
         chk
       )
       (foreach pt septs
         (if (eq (length (chkduppt pt septs)) 2) (setq septn (cons pt septn)))
       )
       (foreach pt septn
         (setq sept (vl-remove pt sept))
       )
       (if (eq sept nil) (setq sept (acet-list-remove-duplicates septs 1e-6)))
       (repeat (setq k (sslength ss))
         (setq ent (ssname ss (setq k (1- k))))
         (setq stpt (cdr (assoc 10 (entget ent))))
         (if (equal stpt (car sept) 1e-6) (setq stent ent))
       )
       (if (eq stent nil)
         (repeat (setq k (sslength ss))
           (setq ent (ssname ss (setq k (1- k))))
           (setq enpt (cdr (assoc 11 (entget ent))))
           (if (equal enpt (car sept) 1e-6) (setq enent ent))
         )
       )
       (if stent
       (progn
         (setq ptlst (cons (cdr (assoc 10 (entget stent))) ptlst))
         (setq ptlst (cons (cdr (assoc 11 (entget stent))) ptlst))
         (setq enpt (cdr (assoc 11 (entget stent))))
         (ssdel stent ss)
       )
       (progn
         (setq ptlst (cons (cdr (assoc 11 (entget enent))) ptlst))
         (setq ptlst (cons (cdr (assoc 10 (entget enent))) ptlst))
         (setq enpt (cdr (assoc 10 (entget enent))))
         (ssdel enent ss)
       )
       )
       (while (/= (sslength ss) 0)
         (setq nxtentst nil)
         (setq nxtenten nil)
         (repeat (setq k (sslength ss))
           (setq ent (ssname ss (setq k (1- k))))
           (setq stpt (cdr (assoc 10 (entget ent))))
           (if (equal enpt stpt 1e-6) (setq nxtentst ent))
         )
         (if nxtentst nil
           (repeat (setq k (sslength ss))
             (setq ent (ssname ss (setq k (1- k))))
             (setq enptt (cdr (assoc 11 (entget ent))))
             (if (equal enpt enptt 1e-6) (setq nxtenten ent))
           )
         )
         (if nxtentst
         (progn
           (setq ptlst (cons (cdr (assoc 10 (entget nxtentst))) ptlst))
           (setq ptlst (cons (cdr (assoc 11 (entget nxtentst))) ptlst))
           (setq enpt (cdr (assoc 11 (entget nxtentst))))
           (ssdel nxtentst ss)
         )
         (progn
           (setq ptlst (cons (cdr (assoc 11 (entget nxtenten))) ptlst))
           (setq ptlst (cons (cdr (assoc 10 (entget nxtenten))) ptlst))
           (setq enpt (cdr (assoc 10 (entget nxtenten))))
           (ssdel nxtenten ss)
         )
         )
       )
       (setq ptlst (acet-list-remove-duplicates ptlst 1e-6))
       (command "_.3DPOLY")
       (foreach pt ptlst
         (command "_non" pt)
       )
       (command "")
       (setq el (entlast))
       (setq elll (cons el elll))
       (while (eq (cdr (assoc 0 (entget (setq el (entnext el))))) "VERTEX"))
       (foreach l ell
         (entdel l)
       )
     )
     (progn
       (setq ellss (ssadd))
       (foreach l ell
         (ssadd l ellss)
       )
       (foreach l ell
         (command "_.JOIN" l ellss "")
       )
       (setq el (entlast))
       (setq elll (cons el elll))
     )
   )
 )

 (while (setq el (entnext el))
   (setq ell (cons el ell))
 )
 (l-join ell)
 (princ)
)

(defun c:projcurvestotin nil
 (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
 (prompt "\nSelect tin surface made of 3D FACES...")
 (while (not (ssget "_:L" '((0 . "3DFACE"))))
   (prompt "\nEmpty sel.set... Please select TIN surface again...")
   (ssget "_:L" '((0 . "3DFACE")))
 )
 (command "_MESHSMOOTH")
 (prompt "\nType \"P\", then hit ENTER twicely; \nafter that type \"UNION\" and select tin surface again, choose 3rd option; \nthen type \"(continue)\" and select curves that are to be projected to TIN surface; \nafter that press ctrl+shift+c to copybase selected projected curves with base 0,0,0 - use \"Previous\" sel.set; \ntype \"UNDO\" \"B\" and then finally \nmove mouse slightly and press ctrl+v and insert projected curves back using 0,0,0 as insertion point...")
 (textscr)
 (princ)
)

Regards, HTH, M.R.

After the union command i choose the 3rd option.Convert my Tins to something like a net. Then the lisp stops.I write CONTINUE but nothing happend !!

After the union command i choose the 3rd option.Convert my Tins to something like a net. Then the lisp stops.I write CONTINUE but nothing happend !!

NOT "CONTINUE", but "(continue)"... Try it again...

prodromosm, have you managed to use my latest code properly?... I've updated code once again in order to give better explanation inside routine; also added undomark, so you can copybase new projected curves into memory, do one "UNDO" "B", and paste them back into unmodified TIN... Now I think my code is finished as it should, but I didn't see positive responses from you, and I suppose that as no one didn't have any remarks ab routine but you that it works fine like it's supposed to...

So long from me, M.R.