多段线实交问题
刚学lisp不久，参考了别人的代码，写了这个多段线实交程序。就是选择一根线，与他平面相交的线段，在相交处各自加个点。高程使用相交线的高程。 有点问题，内循环坐标排序没问题，外循环坐标排序就有问题了，代码如下，希望高手帮帮忙改一下：(defun c:xsj( / m n j m_jd dwlen xlen xlist fwxxz ent m_jdtab newxianzb xlistlayt m_vlaobjcopy m_vlaobjcopy1 )
(setvar "cmdecho" 0)
(command "undo" "be")
(vl-load-com)
(setq ent(ssget (list(cons 8 "*") (cons 0 "POLYLINE,LWPOLYLINE"))))
(if(/= ent nil)
(progn
(setq m 0)
(setq xlen(sslength ent))
(while(< m xlen)
(setq m_jdtab '())
(setq scdwsjx(ssadd))
(setq m_entab(ssname ent m))
(setq xxxssdd m_entab)
(setq m_vlaobj (vlax-ename->vla-object m_entab))
(vla-getboundingbox m_vlaobj 'm_wlbpt 'm_wrupt)
(setq m_wlbpt (vlax-safearray->list m_wlbpt));;窗口左下角点
(setq m_wrupt (vlax-safearray->list m_wrupt));;窗口右上角点
(vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point m_wlbpt)(vlax-3d-point m_wrupt));;缩放以使剖切线充满屏幕
(setq m_vlaobjcopy (m_shadowtoxy (vla-copy (vlax-ename->vla-object m_entab))));;复制并求投影实体
(setq layt(cdr(assoc 8 (entget m_entab))))
(setq xlist(GetListOfPline m_entab))
(setq fwxxz(ssget "F" xlist (list(cons 8 "*") (cons 0 "POLYLINE"))))
(if(/= fwxxz nil)
(progn
(setq n 0)
(setq dwlen(sslength fwxxz))
(while (< n dwlen)
(setq dwjd nil dwxbb nil)
(setq dwx(ssname fwxxz n))
(ssadd dwx scdwsjx)
(setq dwlayt(cdr(assoc 8 (entget dwx))))
(setq dwlist(GetListOfPline dwx))
(setq m_vlaobjcopy1(m_shadowtoxy(vla-copy (vlax-ename->vla-objectdwx))));;复制并求投影实体;;
(setq m_jdtab1 (vla-intersectwith m_vlaobjcopy m_vlaobjcopy1 acExtendnone ) );;求剖切线与曲线实体的交点表
(if (> (vlax-safearray-get-u-bound (vlax-variant-value m_jdtab1) 1) 1) ;;判断有无交点
(progn
(setq m_jdtab1 (vlax-safearray->list (vlax-variant-value m_jdtab1)));;safearray数组转换为list表
(setq j 0)
(repeat (/ (length m_jdtab1) 3)
(setq m_jd (list (nth j m_jdtab1)
(nth (+ 1 j) m_jdtab1)
(nth (+ 2 j) m_jdtab1)
)
);;取得交点在投影的剖切线上
(setq m_len (distance m_jd (vlax-curve-getstartpoint m_vlaobjcopy)));;交点到线起点得长度
(setq m_jd (vlax-curve-getClosestPointToProjection
(vlax-ename->vla-object dwx)
(list (car m_jd) (cadr m_jd) 0.0)
'(0 0 1)
)
);;取得交点在实际的等高线上（主要是得到高程）
(setq m_jdtab (cons m_jd m_jdtab));;构造交表;
(setq dwjd(cons m_jd dwjd))
(setq j (+ 3 j))
)
(setq dwxbb(del-rept2 (SortPointByCurve(append dwlist dwjd) (vlax-ename->vla-object dwx))))
(if(equal (car dwlist) (last dwlist) 0.001) (setq dwxbb(reverse(cons (car dwxbb) (reverse dwxbb)))))
(huabiaopline dwxbb dwlayt)
)
)
;(command "erase" dwx "")
(vla-delete m_vlaobjcopy1) ;;删除复制的曲线实体
(setq n(+ 1 n))
)
))
(vla-delete m_vlaobjcopy);;删除复制体
(setq newxianzb (del-rept2 (SortPointByCurve (append xlist m_jdtab) (vlax-ename->vla-object m_entab))));;;;此处坐标点排序就会出错；；
(if(equal (car xlist) (last xlist) 0.001) (setq newxianzb(reverse(cons (car newxianzb) (reverse newxianzb)))))
(command "erase" m_entab "")
(command "erase" scdwsjx "")
(huabiaopline newxianzb layt)
(setq m( + 1 m))
)
))
(command "undo" "e")
(prin1)
)
；；；；；；；；；；；；；；
;;;;;;;;;;;;;;;;;;;;;;;;;;;;点表按实体排序;;;;
;;;;;;;;;;;;;;;;;;;points 点表curve线实体;;;
(defun SortPointByCurve (points curve / pl1 xx nn curve pl1)
(setq pl1 (mapcar '(lambda (xx /)
(vlax-curve-getparamatpoint
curve
(vlax-curve-getclosestpointto curve xx)
)
)
points
)
)
(mapcar '(lambda (nn) (nth nn points))
(vl-sort-i pl1 '<)
)
)
；；；；；；；；；；；；；
;;;;;画坐标表
(defun huabiaopline(llt_list_huabiao pl_ys / ttlen kkm 2wptxyz)
(command "clayer"pl_ys )
(setq ttlen(length llt_list_huabiao))
(setq kkm 0 )
(command "3dpoly")
(while(< kkm ttlen)
(setq 2wptxyz (nth kkm llt_list_huabiao))
(command 2wptxyz)
(setq kkm (1+ kkm))
)
(if(equal (car llt_list_huabiao) (last llt_list_huabiao) 0.001)
(command "c")
(command "")
)
)
;;;;;;;;;;;;;;;;;;;;;多段线各坐标列表
(defun GetListOfPline (EntityName / SSE_Pline N newEntityName n SSE_Pline lastxyz)
;(setq EntityName(car(entsel)))
(setq SSE_Pline (entget EntityName))
(setq LastList nil)
(if (= (cdr (assoc 0 SSE_Pline)) "LWPOLYLINE")
(progn
(setq bd70 (cdr (assoc 70 (entget EntityName))))
(setq lastz(cdr(assoc 38 SSE_Pline)))
;(setq LastList nil)
(setq N 0)
(while (/= (nth N SSE_Pline) nil)
(if (= (car (nth N SSE_Pline)) 10)
(progn
(setq lastxyz (cdr(nth N SSE_Pline)))
(setq lastxyz(list (car lastxyz) (cadr lastxyz) lastz))
(setq LastList (cons lastxyz LastList))
))
(setq N (+ N 1))
)
;(setq LastList (cdr LastList))
(IF (OR (= bD70 1) (= bD70 9) (= bD70 129))
(progn
(setq LastList(cons (last LastList) LastList))
(setq plnclose_bihe 1)
))
)
)
(if (= (cdr (ASSOC 0 SSE_Pline)) "POLYLINE")
(PROGN
(setq bd70 (cdr (assoc 70 (entget EntityName))))
;(setq LastList nil)
(setq newEntityName (entnext EntityName))
(while (= (cdr (assoc 0 (entget newEntityName))) "VERTEX")
(setq lastxyz(cdr(assoc 10 (entget newEntityName))))
(setq LastList (cons lastxyz LastList))
(setq newEntityName (entnext newEntityName))
)
;(setq LastList (cdr LastList))
(IF (OR (= bD70 1) (= bD70 9) (= bD70 129))
(progn
(setq LastList(cons (last LastList) LastList))
(setq plnclose_bihe 1)
))
)
)
(setq LastList (reverse LastList))
;(setq LastList (reverse LastList))
);_defun
;;;;;;;;;;;;;;;;;;;;
(defun m_shadowtoxy (m_obj / m_obj1 m_objname m_pts m_pts1 i)
;;对曲线实体m_obj创建一个投影至xy平面的曲线实体，即对曲线实体上每个控制点的z坐标置为0
;;返回实体名m_obj1
(setq m_objname (vla-get-objectname m_obj))
;;取得实体的类型名称
(cond
((= "AcDbSpline" m_objname)
;;样条曲线(Spline)
(setq i 0)
(setq m_pts (vlax-variant-value (vla-get-fitpoints m_obj)))
;;取得样条曲线的拟合点
(setq m_pts1 (vlax-variant-value (vla-get-controlpoints m_obj)))
;;取得样条曲线的控制点
(repeat (vla-get-numberoffitpoints m_obj)
(vlax-safearray-put-element m_pts (+ i 2) 0.0)
;;改变每个拟合点的z值为0.0
(setq i (+ i 3))
)
(vla-put-fitpoints m_obj m_pts)
;;更改曲线拟合点属性
(setq i 0)
(repeat (vla-get-numberofcontrolpoints m_obj)
;;循环
(vlax-safearray-put-element m_pts1 (+ i 2) 0.0)
;;改变每个控制点的z值为0.0
(setq i (+ i 3))
)
(vla-put-controlpoints m_obj m_pts1)
;;更改曲线控制点属性
)
((= "AcDb3dPolyline" m_objname)
;;三维多段线(3dpolyline)
(setq i 0)
(setq m_pts (vlax-variant-value (vla-get-coordinates m_obj)))
;;取得3维多段线的控制点
(repeat (/ (length (vlax-safearray->list m_pts)) 3)
(vlax-safearray-put-element m_pts (+ i 2) 0.0)
(setq i (+ i 3))
)
(vla-put-coordinates m_obj m_pts)
)
((= "AcDbLine" m_objname)
;;直线(line)
(setq i 0)
(setq m_pts (vlax-variant-value (vla-get-startpoint m_obj)))
;;取得直线的起点座标
(setq m_pts1 (vlax-variant-value (vla-get-endpoint m_obj)))
;;取得直线的终点座标
(vlax-safearray-put-element m_pts 2 0.0)
;;改变起点座标z值为0.0
(vlax-safearray-put-element m_pts1 2 0.0)
;;改变终点座标z值为0.0
(vla-put-startpoint m_obj m_pts)
(vla-put-endpoint m_obj m_pts1)
)
((or (= "AcDbCircle" m_objname)
;;园(circle)
(= "AcDbArc" m_objname)
;;圆弧(arc)
(= "AcDbEllipse" m_objname)
;;椭圆及椭圆弧(ellipse)
)
(setq m_pts (vlax-variant-value (vla-get-center m_obj)))
(vlax-safearray-put-element m_pts 2 0.0)
;;改变中心点座标z值为0.0
(vla-put-center m_obj m_pts)
)
((or (= "AcDbPolyline" m_objname)
;;多段线(polyline、lwpolyline)
(= "AcDb2dPolyline" m_objname)
;;拟合的2维多段线(polyline、lwpolyline)
)
(vla-put-elevation m_obj 0.0)
;;改变标高值为0.0
)
)
(setq m_obj1 m_obj)
)
;;;;;;;;;;;;;;
;;;;;;;;;;;;;删除重复点
(defun del-rept2(lst / nl )
(setq nl nil)
(mapcar
'(lambda(x)
(if (not (member x nl))
(setq nl (cons x nl))
)
)
lst
)
(reverse nl)
)
都没人帮忙呀，版主帮忙解决一下撒 已搞定，居然没人看出来，F选择的后，没有把自身删除掉，多了一根线 朋友你这太长了。呵呵。 153490125 发表于 2012-1-30 10:35 static/image/common/back.gif
已搞定，居然没人看出来，F选择的后，没有把自身删除掉，多了一根线
能把定稿的发布出来学习下吗
页:
[1]