明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1012|回复: 6

[源码] 从等高线上剖断面探讨

[复制链接]
发表于 2015-7-17 08:42 | 显示全部楼层 |阅读模式
    从网站上看到好多关于剖切等高线获取剖面的文章,其实核心问题就是获得剖切线与多条等高线的交点列表,然后根据点表处理生成断面。通过几天的搜罗,发现了这个代码较为复核要求,但是每剖一个断面需要选择等高线,甚是麻烦。看论坛高人们能否改进,直接选取剖切线后就能生成剖面,源代码如下:

     ;;功能:在地形图上截断面
;;命令:dm
;;说明:
(vl-load-com)
(defun C:DM (/ M_OBJ1 M_ENT1 M_ENT2 M_JDTAB100)
  (princ "\n请选择地形线:  ")
  (setq
    NUMBER
     (getint
       " 0=样条曲线; 1=多段线;2=样条曲线和多段线<默认0>:"
     )
  )
  (cond
    ((= NUMBER 0) (setq SS (ssget '((0 . "SPLINE")))))
    ((= NUMBER 1) (setq SS (ssget '((0 . "*POLYLINE")))))
    ((= NUMBER 2) (setq SS (ssget '((0 . "*POLYLINE,SPLINE")))))
    (t (setq SS (ssget '((0 . "SPLINE")))))
  )
  ;;
  (if (and SS
           (setq OBJ_0 (entsel "\n请选择剖面线: "))
           (= (cdr (assoc 0 (entget (car OBJ_0)))) "LINE") ;_目前只支持直线段
      )
    (progn
      ;;转化对象类型
      (setq OBJ_0 (vlax-ename->vla-object (car OBJ_0)))

      ;;获取交点
      (setq LST_PT '()
            I 0
      )
      (repeat (sslength SS)
        (setq OBJ_1  (vlax-ename->vla-object (ssname SS I))
              TMP    (ZL-GETINTERS OBJ_0 OBJ_1 0 "F2" NIL)
              LST_PT (append TMP LST_PT)
        )
        (setq I (1+ I))
      )
      ;; 排序
      ;; 点表按照xyz从小到大排序
      (setq LST_PT (vl-sort LST_PT
                            '(lambda (P1 P2)
                               (< (cadr P1) (cadr P2))
                             )
                   )
            LST_PT (vl-sort LST_PT
                            '(lambda (P1 P2)
                               (< (car P1) (car P2))
                             )
                   )
      )
      ;;绘制
      (command "_.3dpoly")
      (foreach PT LST_PT
        (command "non" PT)
      )
      (command "")
      ;;显示
      (foreach PT LST_PT
        (princ PT)
      )
(COMmAND "PLINE" PT "")
      (princ "程序完毕")
    )
  )
  (princ)
)


;;;=============================================================================


;|;;===========================================================================
      通用函数                                                                ;
功能:求两个线条对象的交点                                                    ;
      适用对象: Line、Circle、Arc、Ellipse、Polyline、                        ;
      LWPolyline、3dPolyline、Spline                                          ;
参数:OBJ1   ----对象1                                                        ;
      OBJ2   ----对象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

 楼主| 发表于 2015-7-17 11:21 | 显示全部楼层
论坛这么静悄悄的;
回复 支持 1 反对 0

使用道具 举报

 楼主| 发表于 2015-7-17 08:43 | 显示全部楼层
DM.LSP如下,求改进。

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
回复 支持 1 反对 0

使用道具 举报

 楼主| 发表于 2015-7-17 08:47 | 显示全部楼层
地形图送上,免得耽搁你们宝贵时间

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2015-7-17 12:38 | 显示全部楼层
zml84 版主的这个函数有点啰嗦,开初我也用它

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
 楼主| 发表于 2015-7-17 15:05 | 显示全部楼层
自贡黄明儒 发表于 2015-7-17 12:38
zml84 版主的这个函数有点啰嗦,开初我也用它

你这个是什么工具啊
发表于 2015-7-22 11:14 | 显示全部楼层
选择剖面线,读取剖面线的二个点,(ssget "F" pt1 pt2),
这样不就可以达到你的需求了!
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 18:20 , Processed in 0.224735 second(s), 31 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表