给多线段添加顶点的若干版本及问题求解

yxh1202

最近需要在一个道路横断面上增加与中桩线的交点作为新顶点，我按照自贡黄宏玉的代码，参考前辈的资料，自己编了一个，问题是运行后地面线变乱了，这样导出的线段与中桩的高差平距关系也就错了，请指点：


完整代码如下：
;;----------------=={ 选择两条线，将交点添加到第一条线中，并导出高差平距数据 }==---------------;;

(defun C:TT (/ S1 S2 OBJ1 OBJ2 pt filename e n fn jd ptt pts number
             str_1)
  (vl-load-com)
  (if (and (setq S1 (entsel "\n选择地面线："))
           (setq S2 (entsel "\n选择中桩线："))
      )
    (progn (setq OBJ1 (vlax-ename->vla-object (car S1))
                 OBJ2 (vlax-ename->vla-object (car S2))
           )
           (setq ptlist (ZL-GETINTERS OBJ1 OBJ2 0 "F1" 0.05))
           (setq pt1 (car ptlist)
                 pt2 (cdr ptlist)
           )
    )
  )
  (setq pt pt1)
  (setq pt (mapcar '+ '(0 0) pt))
  ;;增加交点到第一条线中
  (vlax-invoke OBJ1 'addvertex 2 pt)
  (princ)


;;;本程序命令为hdmout,仅针对图纸比例为1：1的情况而言，若比例不是1：1，请自行调整图纸比例
;;;本程序需选择断面桩号、坐标系基准中心、选择基准中心处的断面高程数据
;;;本程序所获得的数据为追加形式，一次采取一条断面，可以累加
  (setq
    str_1 (cdr
            (assoc 1 (entget (car (entsel "请选择一个断面桩号："))))
          )
  )
  (setq point_1 pt1)
  (setq        px_1 (car point_1)
        py_1 (cadr point_1)
  )
  (setq        e55
         (cdr
           (assoc 1
                  (entget (car (entsel "\n 请选取该断面的中心高程数据:")))
           )
         )
  )
  (setq bb (vl-string->list e55))
  (setq cc (vl-remove-if '(lambda (x) (> x 57)) bb))
  (setq de (vl-remove-if '(lambda (x) (< x 43)) cc))
  (setq height_1 (atof (vl-list->string de)))
  (if (setq s (ssget ":S" '((0 . "*POLYLINE")))) ;_点选带过滤形式
    (progn
      (setq e           (ssname s 0)
            number (fix (vlax-curve-getendparam e))
            n           (+ 1 number)
      )
      (if (not (setq filename
                      (getfiled "选择文件存储目录" "d:/断面线数据.txt" "txt" 33)
               )
          )
        (setq filename "c:\\断面线数据.txt")
      )
      (setq fn (open filename "a")
            jd n
      )
      (WRITE-LINE
        (strcat "BEIGIN " str_1)
        fn
      )
      (setvar "dimdec" 3)
      (repeat n
        (setq ptt (vlax-curve-getpointatparam e (setq jd (1- jd))))
        (if (null pts)
          (setq pts (list ptt))
          (if (not (equal ptt (car pts) 1e-3))
            (setq pts (cons ptt pts))
          )
        )
      )
      (setq n 1)
      (mapcar '(lambda (x)
                 (write-line
                   (strcat
                     (rtos (- (car x) px_1))
                     " "
                     (rtos (+ height_1 (- (cadr x) py_1))) ;_与前面的 dimzin 配合采用用户 UNITS 精度设置
                   )
                   fn
                 )
                 (setq n (1+ n))
               )
              pts
      )
      (WRITE-LINE "NEXT" fn)
      (close fn)
    )
  )
  (princ "\n")
)

;;;===========================================================================       通用函数
;;; 功能：求两个线条对象的交点
;;;适用对象: Line、Circle、Arc、Ellipse、Polyline、LWPolyline、3dPolyline、Spline
;;;参数：OBJ1   ----对象1 、BJ2   ----对象2、
;;;Extend ----延伸选项   0  acExtendNone   1  acExtendThisEntity   2  acExtendOtherEntity     3  acExtendBoth
;;;ZZZ    ----输出选项  "=0"  Z值取0   "F1"  取第一个对象上的点  "F2"  取第二个对象上的点    "MAX" 取Z值大者    "MIN" 取Z值小者
;;;Fuzz   ----允许偏差值
;;; 返回：若成功，返回点位表；否则返回nil 日期：zml84 于2007-11-05

(vl-load-com)
(defun ZL-GETINTERS (OBJ1   OBJ2   EXTEND ZZZ         FUZZ        /      ENT1
                     ENT2   PT10   PT11          PT20         PT21        OBJ11  OBJ22
                     ARRAY  LST           LST_PT I         PT        PT1    PT2
                     Z1            Z2
                    )
  ;;0、对参数的格式化处理
  (if (and (= (type EXTEND) 'INT)
           (<= 0 EXTEND 3)
      )
    ()
    (setq EXTEND 0)
  )
  (setq ZZZ (strcase ZZZ))
  ;;======================     ;;1、获取交点集合>>>>>>>
  (if (and (= (vla-get-objectname OBJ1) "AcDbLine")
           (= (vla-get-objectname OBJ2) "AcDbLine")
      )
    ;;对直线对象(line) 特别处理
    (progn (setq ENT1 (entget (vlax-vla-object->ename OBJ1))
                 ENT2 (entget (vlax-vla-object->ename OBJ2))
           )
           (setq PT10 (assoc 10 ENT1)
                 PT11 (assoc 11 ENT1)
                 PT20 (assoc 10 ENT2)
                 PT21 (assoc 11 ENT2)
           )
           ;;去除Z坐标
           (setq PT10 (list (cadr PT10) (caddr PT10))
                 PT11 (list (cadr PT11) (caddr PT11))
                 PT20 (list (cadr PT20) (caddr PT20))
                 PT21 (list (cadr PT21) (caddr PT21))
           )
           (setq LST (inters PT10 PT11 PT20 PT21 t))
           (if LST
             (setq LST (append LST '(0)))
           )
    )
    (progn
      ;;=====================
      ;;复制实体
      (setq OBJ11 (vla-copy OBJ1)
            OBJ22 (vla-copy OBJ2)
      )
      ;;向xy平面投影，将Z坐标改为0
      (TOXY OBJ11)
      (TOXY OBJ22)
      ;;获取交点集合
      (setq ARRAY (vla-intersectwith OBJ11 OBJ22 EXTEND))
      ;;删除复制后的对象
      (vla-delete OBJ11)
      (vla-delete OBJ22)
      ;;由数组转换为表
      (if
        (and ARRAY
             (>        (vlax-safearray-get-u-bound (vlax-variant-value ARRAY) 1)
                1
             )
        )
         (progn
           (setq LST (vlax-safearray->list (vlax-variant-value ARRAY)))
         )
      )
    )
  )
  ;;======================
  ;;2、分析整理>>>>>>>
  (setq LST_PT '())
  (if LST
    (progn (setq I 0)
           (repeat (/ (length LST) 3)
             ;;2.1 获取当前点位
             (setq PT (list (nth I LST) (nth (+ 1 I) LST) (nth (+ 2 I) LST)))
             ;;2.2 获取对象上对应点位
             (setq PT1 (vlax-curve-getclosestpointtoprojection OBJ1 PT '(0 0 1))
                   PT2 (vlax-curve-getclosestpointtoprojection OBJ2 PT '(0 0 1))
             )
             (setq Z1 (caddr PT1)
                   Z2 (caddr PT2)
             )
             ;;2.3 效验偏差值
             ;;就是说：过滤:参数中有偏差值选项，却不满足要求的点位
             (if (and FUZZ
                      (or (= (type FUZZ) 'REAL) (= (type FUZZ) 'INT))
                      (not (equal Z1 Z2 FUZZ))
                 )
               ;; 空处理
               ()
               ;;2.4 对输出选项的处理
               (progn (cond ((= ZZZ "F1") (setq PT PT1))
                            ((= ZZZ "F2") (setq PT PT2))
                            ((= ZZZ "MAX")
                             (if (> Z1 Z2)
                               (setq PT PT1)
                               (setq PT PT2)
                             )
                            )
                            ((= ZZZ "MIN")
                             (if (< Z1 Z2)
                               (setq PT PT1)
                               (setq PT PT2)
                             )
                            )
                            (t (setq PT PT))
                      ) ;_结束cond
                      (if (member PT LST_PT)
                        ()
                        (setq LST_PT (cons PT LST_PT))
                      )
               )
;_结束progn
             )
;_结束if
             (setq I (+ I 3))
           )
;_结束repeat
    ) ;_结束progn
  ) ;_结束if
  ;;3、返回结果>>>>>
  LST_PT
)
;_结束defun
;;;==========================================
;;;功能：曲线实体上每个控制点的z坐标值置为0.0
(defun TOXY (OBJ / NAME PT1 TP2)
  ;;取得实体的类型名称
  (setq NAME (vla-get-objectname OBJ))
  (cond
    ;;类型1 ;;直线
    (line)
    ((= NAME "AcDbLine")
     ;;取得直线的起终点坐标
     (setq PT1 (vlax-variant-value (vla-get-startpoint OBJ))
           PT2 (vlax-variant-value (vla-get-endpoint OBJ))
     )
     ;;改变z值为0.0
     (vlax-safearray-put-element PT1 2 0.0)
     (vlax-safearray-put-element PT2 2 0.0)
     (vla-put-startpoint OBJ PT1)
     (vla-put-endpoint OBJ PT2)
    )
    ;;类型2 ;;圆(circle) ;;圆弧(arc) ;;椭圆及椭圆弧
    (ellipse)
    ((or (= NAME "AcDbCircle")
         (= NAME "AcDbArc")
         (= NAME "AcDbEllipse")
     )
     ;;取得中心点座标
     (setq PT1 (vlax-variant-value (vla-get-center OBJ)))
     ;;改变中心点座标z值为0.0
     (vlax-safearray-put-element PT1 2 0.0)
     (vla-put-center OBJ PT1)
    )
    ;;类型3 ;;多段线(polyline、lwpolyline)
    ;;拟合的2维多段线
    (polyline、lwpolyline)
    ((or (= NAME "AcDbPolyline") (= NAME "AcDb2dPolyline"))
     ;;改变标高值为0.0
     (vla-put-elevation OBJ 0.0)
    )
    ;;类型4 ;;三维多段线(3dpolyline)
    ((= NAME "AcDb3dPolyline")
     ;;取得3维多段线的控制点
     (setq PT1 (vlax-variant-value (vla-get-coordinates OBJ))
           I   0
     )
     (repeat (/ (length (vlax-safearray->list PT1)) 3)
       (vlax-safearray-put-element PT1 (+ I 2) 0.0)
       (setq I (+ I 3))
     )
     (vla-put-coordinates OBJ PT1)
    )
    ;;类型5 ;;样条曲线(Spline)
    ((= NAME "AcDbSpline")
     ;;取得样条曲线的拟合点
     ;;改变每个拟合点的z值为0.0
     (setq PT1 (vlax-variant-value (vla-get-fitpoints OBJ))
           I   0
     )
     (repeat (vla-get-numberoffitpoints OBJ)
       (vlax-safearray-put-element PT1 (+ I 2) 0.0)
       (setq I (+ I 3))
     )
     (vla-put-fitpoints OBJ PT1)
     ;;取得样条曲线的控制点  ;;改变每个控制点的z值为0.0
     (setq PT2 (vlax-variant-value (vla-get-controlpoints OBJ))
           I   0
     )
     (repeat (vla-get-numberofcontrolpoints OBJ)
       (vlax-safearray-put-element PT2 (+ I 2) 0.0)
       (setq I (+ I 3))
     )
     (vla-put-controlpoints OBJ PT2)
    )
    (t NIL)
  )
)
;_结束defun ;;;