将二维多段线转换为三维多边形
你好我有一个小问题，我需要一些帮助。我想使用等高线的删除将一些二维多段线转换为三维多段线。我正在用lisp搜索一条二维多段线，并使用等高线元素将其转换为三维
谢谢
测试1.dwg 看看这是否能帮到你，这是个小傻瓜，但我能做到。。。
(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感谢您的回复。我测试了你的代码，但我有这个错误。
1） i wrire projcurvestotin公司
2） 我选择所有3d面
3） 我写p（并选择二维多段线）
4） 给我错误！！！
我假设您实际上希望在现有的二维等高线上覆盖一条线，并创建一条三维多段线。
我不久前写了这段代码。它还包括Lee Mac针对我发布的代码编写的代码。
;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。这个Lisp程序是怎么运行的？ Hippe013我已经准备好了所有3d轮廓。在它们上面我有二维多段线。我想使用等高线的删除将二维多段线转换为三维多段线。 你Lisp程序了吗？
你知道如何运行lisp吗？
这段代码在轮廓上覆盖一条线，并创建一条3dpolyline。这不是你想要的吗？将二维多段线（图形中的黄色）替换为直线。运行提供的代码。选择该线，您将看到一条三维多段线覆盖在等高线上。
如果这不是你想要的，那么也许你需要更清楚地了解你的要求。
当做
hippe013 Hippe013现在你可以理解如何运行Lisp程序了。我键入LWPOLYSAMPLE并选择一条线，然后将其转换为多段线。
我想将三维多段线添加到图层。你能告诉我我们要添加这个图层命令吗
（命令“_layer”“m”“3d polyline”“c”“3”）
谢谢 我已经修正了我的代码一点。。。我不知道，我可以按照我在例行程序中解释的那样做。。。我已经在A2014上测试过了，它应该可以使用3d曲线实体，而不仅仅是直线或柱脚。。。
请再试一次，因为我已将子功能更改为独立于主功能。。。 如果希望将三维多段线添加到某个图层。然后（使用我的代码c:sample pl）进行以下编辑。
(vlax-put-property 3dobj2 'Color 1)
(vlax-put-property 3dobj2 'Layer "WHATEVER-LAYER-YOU-WANT")
(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
我希望这有帮助。
P、 我建议您使用VLIDE（visual lisp编辑器）进行编辑。
页:
[1]
2