求剖切线与等高线的交点写高程

清风明月10 · 发表于 2013-7-6 10:32:26

本帖最后由 newer 于 2021-2-4 05:28 编辑

各位高手，我请求帮我写一个代码，就是一条曲线A为剖切线，再B图层中的所有线均有高程线（线群为C），我要求剖切线A与C群中每一条等高线E的交点D，并在D点插入一个TEXT，这个单行文字的内容为E的Z值，TEXT的Z值与E的Z值相等。
剖切线及等高线均应为普通任意线型，直线、多义线样条曲线等。剖切线可不为三维多义线，等高线可为三维多义线。
我要求得到源码，方便作灵活改造。
拜求各位帮忙
管理员别生气，我前面将这个帖子发到提问里面了，后面想提问里面没有悬赏，恐大家没有积极性，所以又发到这里。前面那个帖子我不知道如何能转到这里，所以重发。

我来回答

aeo · 发表于 2013-7-6 10:32:27

纯lisp
在没有函数库的情况下写真麻烦
试试行不行

游客，本帖隐藏的内容需要积分高于 35 才可浏览，您当前积分为 0

XDSoft · 发表于 2013-7-6 11:14:28

传上一个图片说明和 DWG测试文件吧。

清风明月10 · 发表于 2013-7-7 19:56:08

我自己编好了，当然代码也是又是写又是抄的
CJ001027在剖切线与等高线群的外观交点上写内容为高程的TEXT.LSP

(DEFUN C:UU ()
(vl-load-com)
(setq m_ent1 (car (entsel "\n请选择剖切线: ")))
(setq m_ent2 (car (entsel "\n请选择一条等高线: ")))
(setq data (entget m_ent2))
(setq layer (assoc 8 data))
(setq (CDR layer))
(SETQ SS (SSGET "X" (list (cons 8) (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE"))))
(SSSETFIRST SS)
(setq ii 0)
(repeat (sslength ss) ; 循环选择集长度
(setq (ssname ss ii))
(setq ZL-GETINTERS (m_IntersectWith m_ent1))
(setq (CADDR (vlax-curve-getStartPoint)) ; ps2(vlax-curve-getEndPoint m_ent2)
)
(foreach n ZL-GETINTERS ; (print n)
(setq xzb (car n))
(setq yzb (cadr n))
(entmake (list (cons 0 "TEXT") (cons 1 (vl-princ-to-string)) (cons 10 (list XZB YZB)) (cons 40 2.5) (cons 8 "0000用于图元属性快速输出利用（简称“属性”图层）")))
)
(setq ii (1+ ii))
) ; (sssetfirst nil ss)
)
(defun m_IntersectWith (m_ent1 / m_obj1 m_obj2 m_objcopy1 m_objcopy2 m_jdtab m_jdtab1 i) ; 来源：3楼
; [求助]任意两条线的交点坐标-AutoLISP/Visual LISP 编程技术-CAD论坛-明经CAD社区 -
; Powered by Discuz!
; http://bbs.mjtd.com/forum.php?mod=viewthread&tid=79868
; 适用对象: Line、Polyline、LWPolyline、Circle、Arc、Ellipse、3dPolyline、Spline
; 支持求空间虚交点，但Z坐标始终为0.0，要求Z坐标，请用(vlax-curve-getClosestPointTo
; Projection)函数
(setq m_obj1 (vlax-ename->vla-object m_ent1))
(setq m_obj2 (vlax-ename->vla-object))
(setq m_objcopy1 (vla-copy m_obj1)) ; 复制第一条曲线实体
(setq m_objcopy2 (vla-copy m_obj2)) ; 复制第二条曲线实体
(setq m_objcopy1 (m_ShadowToXY m_objcopy1)) ; 得到投影实体
(setq m_objcopy2 (m_ShadowToXY m_objcopy2)) ; 得到投影实体
(setq m_jdtab1 (vla-intersectwith m_objcopy1 m_objcopy2 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 i 0)
(repeat (/ (length m_jdtab1) 3)
(setq m_jd (list (nth i m_jdtab1) (nth (+ 1 i) m_jdtab1) (nth (+ 2 i) m_jdtab1))) ; 取得一个交点
(setq m_jdtab (cons m_jd m_jdtab)) ; 构造交点表（(第一个交点) (第二个交点)。。。）
(setq i (+ 3 i))
)
)
(princ "\n两曲线无交点!")
)
(vla-delete m_objcopy1) ; 删除复制的第一条曲线实体
(vla-delete m_objcopy2) ; 删除复制的第二条曲线实体
(setq m_jdtab m_jdtab) ; 返回交点表，无交点返回nil
)
(defun m_ShadowToXY (m_obj / m_objname m_pts m_pts1 i) ; 对曲线实体m_obj创建一个投影至xy平面的曲线实体，即对曲线实体上每?
; 隹刂频愕膠坐标值置为0.0
; 输入曲线实体(vla对象)
; 返回投影实体(vla对象)
(setq m_objname (vla-get-objectname m_obj)) ; 取得实体的类型名称
; (m_princ "\nObjectName：" m_objname)
(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)
(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_obj m_obj)
)

(DEFUN C:UU () 
  (vl-load-com) 
  (setq m_ent1 (car (entsel "\n请选择剖切线: "))) 
  (setq m_ent2 (car (entsel "\n请选择一条等高线: "))) 
  (setq data (entget m_ent2)) 
  (setq layer (assoc 8 data)) 
  (setq (CDR layer)) 
  (SETQ SS (SSGET "X" (list (cons 8) (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE")))) 
  (SSSETFIRST SS) 
  (setq ii 0) 
  (repeat (sslength ss)                       ; 循环选择集长度 
    (setq (ssname ss ii)) 
    (setq ZL-GETINTERS (m_IntersectWith m_ent1)) 
    (setq (CADDR (vlax-curve-getStartPoint)) ;      ps2(vlax-curve-getEndPoint m_ent2) 
    ) 
    (foreach n ZL-GETINTERS               ;     (print n) 
      (setq xzb (car n)) 
      (setq yzb (cadr n)) 
      (entmake (list (cons 0 "TEXT") (cons 1 (vl-princ-to-string)) (cons 10 (list XZB YZB)) (cons 40 2.5) (cons 8 "0000用于图元属性快速输出利用（简称“属性”图层）"))) 
    ) 
    (setq ii (1+ ii)) 
  )                                       ;  (sssetfirst nil ss) 
) 
 
 
 
(defun m_IntersectWith (m_ent1 / m_obj1 m_obj2 m_objcopy1 m_objcopy2 m_jdtab m_jdtab1 i) ; 来源：3楼 
                                       ; [求助]任意两条线的交点坐标-AutoLISP/Visual LISP 编程技术-CAD论坛-明经CAD社区 - 
                                       ; Powered by Discuz! 
                                       ; <a href=\"http://bbs.mjtd.com/forum.php?mod=viewthread&tid=79868\" target=\"_blank\">http://bbs.mjtd.com/forum.php?mod=viewthread&tid=79868</a> 
                                       ; 适用对象: Line、Polyline、LWPolyline、Circle、Arc、Ellipse、3dPolyline、Spline 
                                       ; 支持求空间虚交点，但Z坐标始终为0.0，要求Z坐标，请用(vlax-curve-getClosestPointTo 
                                       ; Projection)函数 
  (setq m_obj1 (vlax-ename->vla-object m_ent1)) 
  (setq m_obj2 (vlax-ename->vla-object)) 
  (setq m_objcopy1 (vla-copy m_obj1))  ; 复制第一条曲线实体 
  (setq m_objcopy2 (vla-copy m_obj2))  ; 复制第二条曲线实体 
  (setq m_objcopy1 (m_ShadowToXY m_objcopy1)) ; 得到投影实体 
  (setq m_objcopy2 (m_ShadowToXY m_objcopy2)) ; 得到投影实体 
  (setq m_jdtab1 (vla-intersectwith m_objcopy1 m_objcopy2 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 i 0) 
      (repeat (/ (length m_jdtab1) 3) 
        (setq m_jd (list (nth i m_jdtab1) (nth (+ 1 i) m_jdtab1) (nth (+ 2 i) m_jdtab1))) ; 取得一个交点 
        (setq m_jdtab (cons m_jd m_jdtab)) ; 构造交点表（(第一个交点) (第二个交点)。。。） 
        (setq i (+ 3 i)) 
      ) 
    ) 
    (princ "\n两曲线无交点!") 
  ) 
  (vla-delete m_objcopy1)               ; 删除复制的第一条曲线实体 
  (vla-delete m_objcopy2)               ; 删除复制的第二条曲线实体 
  (setq m_jdtab m_jdtab)               ; 返回交点表，无交点返回nil 
) 
(defun m_ShadowToXY (m_obj / m_objname m_pts m_pts1 i) ; 对曲线实体m_obj创建一个投影至xy平面的曲线实体，即对曲线实体上每? 
                                       ; 隹刂频愕膠坐标值置为0.0 
                                       ; 输入曲线实体(vla对象) 
                                       ; 返回投影实体(vla对象) 
  (setq m_objname (vla-get-objectname m_obj)) ; 取得实体的类型名称 
                                       ;  (m_princ "\nObjectName：" m_objname) 
  (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) 
      (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_obj m_obj) 
)

XDSoft · 发表于 2013-7-7 20:47:36

清风明月10 发表于 2013-7-7 19:56
我自己编好了，当然代码也是又是写又是抄的
CJ001027在剖切线与等高线群的外观交点上写内容为高程的TEXT.L ...

等日期到了，悬赏的豆，斑竹可以分配的时候，看看能不能分配到你本人身上。

可以把你程序运行做个动画贴到这个帖子吗，也算是有始有终。

清风明月10 · 发表于 2013-7-7 21:00:24

好不容易学会了录GIF，这是第一次录了发表

eachy · 发表于 2013-7-7 23:47:04

清风明月10 发表于 2013-7-7 21:00
好不容易学会了录GIF，这是第一次录了发表

凭印象用 XDAPI 写了个，没有测试，主要用了 Getstretchpoint ，MoveStretchPoint，思路是先把等高线的拉伸点到 0 （应该是搞到和剖切线一个标高），求得交点后，再次将等高线拉伸回原处，用这个拉伸就不用考虑实体类型了

(defun getinters (e ss / getz getindex el pl1 index v1 v2 ms)
(defun getz (p)
(list 0. 0. (caddr p))
)
(defun addz (p z)
(list (car p) (cadr p) (caddr z))
)
(defun getindex (pl / i)
(setq i -1)
(mapcar '(lambda (x)
(setq i (1+ i))
)
pl
)
)
(setq
ms (vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
)
el (xdrx_pickset->ents ss)
pl1 (mapcar '(lambda (x)
(xdrx_entity_getstretchpoint x)
)
)
index (mapcar '(lambda (x) (getindex x)) pl1)
v1 (mapcar '(lambda (x) (getz x)) (mapcar 'car pl1))
v2 (mapcar '(lambda (x) (mapcar '- x)) v1)
)
(mapcar '(lambda (x y)
(apply 'xdrx_entity_movestretchpoint
(append (list x) y z)
)
)
el
v2
index
)
(setq
pts (mapcar '(lambda (x y) (addz (xdrx_curve_intersect e x) y))
el
v1
)
)
(mapcar '(lambda (x y)
(apply 'xdrx_entity_movestretchpoint
(append (list x) y z)
)
)
el
v1
index
)
(mapcar '(lambda (x)
(vla-addtext ms (vlax-3d-point x) (rtos (caddr x) 2 3))
)
pts
)
)
(defun c:tt (/ e1 e2 pts ss)
(if (and (setq e1 (xdrx_entsel "\n拾取剖切线: "))
(setq e2 (car (entsel "\n拾取等高线: ")))
(setq pts (xdrx_entity_getstretchpoint (car e1)))
(setq ss (ssget "_F" pts (list (assoc 8 (entget (car e1))))))
)
(getinters (car e1) ss)
)
(princ)
)

(defun getinters (e ss / getz getindex el pl1 index v1 v2 ms) 
  (defun getz (p) 
    (list 0. 0. (caddr p)) 
  ) 
  (defun addz (p z) 
    (list (car p) (cadr p) (caddr z)) 
  ) 
  (defun getindex (pl / i) 
    (setq i -1) 
    (mapcar '(lambda (x) 
           (setq i (1+ i)) 
         ) 
        pl 
    ) 
  ) 
  (setq 
    ms      (vla-get-modelspace 
        (vla-get-activedocument (vlax-get-acad-object)) 
      ) 
    el      (xdrx_pickset->ents ss) 
    pl1      (mapcar '(lambda (x) 
             (xdrx_entity_getstretchpoint x) 
           ) 
      ) 
    index (mapcar '(lambda (x) (getindex x)) pl1) 
    v1      (mapcar '(lambda (x) (getz x)) (mapcar 'car pl1)) 
    v2      (mapcar '(lambda (x) (mapcar '- x)) v1) 
  ) 
  (mapcar '(lambda (x y) 
         (apply 'xdrx_entity_movestretchpoint 
            (append (list x) y z) 
         ) 
       ) 
      el 
      v2 
      index 
  ) 
  (setq 
    pts    (mapcar    '(lambda (x y) (addz (xdrx_curve_intersect e x) y)) 
        el 
        v1 
    ) 
  ) 
  (mapcar '(lambda (x y) 
         (apply 'xdrx_entity_movestretchpoint 
            (append (list x) y z) 
         ) 
       ) 
      el 
      v1 
      index 
  ) 
  (mapcar '(lambda (x) 
         (vla-addtext ms (vlax-3d-point x) (rtos (caddr x) 2 3)) 
       ) 
      pts 
  ) 
) 
(defun c:tt (/ e1 e2 pts ss) 
  (if (and (setq e1 (xdrx_entsel "\n拾取剖切线: ")) 
       (setq e2 (car (entsel "\n拾取等高线: "))) 
       (setq pts (xdrx_entity_getstretchpoint (car e1))) 
       (setq ss (ssget "_F" pts (list (assoc 8 (entget (car e1)))))) 
      ) 
    (getinters (car e1) ss) 
  ) 
  (princ) 
)

清风明月10 · 发表于 2013-7-8 08:29:45

但好象是伪源码，需要外部另外的自定义函数支持“XDRX_ENTSEL”

Free-Lancer · 发表于 2013-7-8 08:59:35

XDAPI也是伪源码？这让老大情何以堪！来自: Android客户端

清风明月10 · 发表于 2013-7-8 09:06:29

我说过，我找不到源加载文件时，这套代码就是伪代码，因为对我这用户它实在无效

清风明月10 · 发表于 2013-7-8 09:09:28

老大的自定义函数在哪里下载，能告诉我吗？要不要注册？使用说明在哪里？因为没有使用说明也用不了

Free-Lancer · 发表于 2013-7-8 09:09:48

清风明月10 发表于 1 分钟前

 登录/注册后可看大图

我说过，我找不到源加载文件时，这套代码就是伪代码，因为对我这用户它实在无效

源文件就是一个arx，xdrx.api来自: Android客户端

清风明月10 · 发表于 2013-7-8 09:51:59

我电脑上没有“xdrx.api”，发给我，怎么样？或者给我网址，我去下载

newer · 发表于 2013-7-8 10:06:10

清风明月10 发表于 2013-7-8 09:51
我电脑上没有“xdrx.api”，发给我，怎么样？或者给我网址，我去下载

点论坛上面那个红色的 XDRX_API 广告图片就进去了。

Free-Lancer · 发表于 2013-7-8 10:09:09

清风明月10 发表于半小时前

 登录/注册后可看大图

老大的自定义函数在哪里下载，能告诉我吗？要不要注册？使用说明在哪里？因为没有使用说明也用不了

我没有新说明，猜着用，呵呵
不过上面程序用到的函数在旧手册中有来自: Android客户端

账号		自动登录	找回密码
密码			立即注册

[已解决] 求剖切线与等高线的交点写高程

最佳答案

点评

点评

评分

点评

点评

浏览过的版块