0 Members and 1 Guest are viewing this topic.
If you need contour cross line to 3D polyline
test
FABRICIO28, This lisp create 3Dpolyline from contour.
;;; 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))
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))