多段线实交问题

153490125

       刚学lisp不久，参考了别人的代码，写了这个多段线实交程序。就是选择一根线，与他平面相交的线段，在相交处各自加个点。高程使用相交线的高程。     有点问题，内循环坐标排序没问题，外循环坐标排序就有问题了，代码如下，希望高手帮帮忙改一下：
     (defun c:xsj( / m n j m_jd dwlen xlen xlist fwxxz ent m_jdtab newxianzb xlist  layt 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-object  dwx))));;复制并求投影实体;;
                                           (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)
)

153490125

都没人帮忙呀，版主帮忙解决一下撒

153490125

已搞定，居然没人看出来，F选择的后，没有把自身删除掉，多了一根线

434939575

朋友你这太长了。呵呵。

yxh1202

153490125 发表于 2012-1-30 10:35
已搞定，居然没人看出来，F选择的后，没有把自身删除掉，多了一根线

能把定稿的发布出来学习下吗

czcxxx