[编程交流] 将二维多段线转换为三维多边形

(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)
)

;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)
   )
 )
)

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

(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