设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 行业篇 › AutoCAD与GIS测绘 › 《求助》lsp程序如何从地形图上提取断面数据？
12345下一页
返回列表 发新帖
楼主: skg123

《求助》lsp程序如何从地形图上提取断面数据？

  [复制链接]
xiao1979
发表于 2011-10-18 11:12:45 | 显示全部楼层
我想要这个程序
回复 支持 反对

使用道具 举报

pslstar
发表于 2012-2-6 05:45:35 | 显示全部楼层
不谋而合，该怎么办啊
回复 支持 反对

使用道具 举报

gzbccy
发表于 2013-4-18 20:41:50 | 显示全部楼层
很好，可惜要币
回复 支持 反对

使用道具 举报

kx820506
发表于 2013-4-18 21:27:11 | 显示全部楼层
好东西，但是没有明经币了
回复 支持 反对

使用道具 举报

pmq
发表于 2013-4-30 20:42:55 | 显示全部楼层
测量成图剖面计算 有个 横剖面计算
下载地址 pmq.ys168.com
回复 支持 反对

使用道具 举报

ds-limt
发表于 2013-5-17 11:32:42 | 显示全部楼层
用的吧，不过收费500，嘿嘿，有点贵，却值得，无论多少数据，一键搞定，呵呵，QQ58635053
回复 支持 反对

使用道具 举报

gzxl
发表于 2013-5-17 13:06:39 | 显示全部楼层
这么多人有兴趣啊
  2. (defun c:dmcj ( / a b curve dislst dist ele file filename fistdist fistgcd fistpt gcdz i ispt lst msg name nn ob ob_pl obj
  3.                   objname osmode p1 p2 p3 p4 pathname pl pl1 points pt ptlst ss startpt str textstring use v xx zxd)
  4.   ;;;高程点按曲线进行排序
  5.   (defun dmcj_gcdsort (points curve / pl1 xx nn)
  6.     (if (= (type curve) 'ENAME) (setq curve (vlax-ename->vla-object curve)))
  7.     (setq pl1 (mapcar '(lambda (xx /) (vlax-curve-getParamAtPoint curve (vlax-curve-getClosestPointTo curve xx))) points))
  8.     (mapcar '(lambda (nn) (nth nn points)) (vl-sort-i pl1 '<))
  9.   )
  10.   (defun dmcj_getstr (pt use / a b dislst dist i ispt lst Name ob obj p1 p2 p3 p4 textstring)
  11.     (setq p1 (polar pt 3.92699 (* use 0.01))
  12.           p2 (polar pt 5.49779 (* use 0.01))
  13.           p3 (polar pt 0.785398 (* use 0.01))
  14.           p4 (polar pt 2.35619 (* use 0.01))
  15.     )
  16.     (setq lst (list p1 p2 p3 p4))
  17.     (setq ob (ssget "_CP" lst (list '(-4 . "<OR") '(0 . "*TEXT") '(-4 . "OR>"))))
  18.     (cond
  19.       ((= ob nil) (setq TextString ""))
  20.       ((= (sslength ob) 1)
  21.          (setq TextString (Vlax-Get (vlax-ename->vla-object (ssname ob 0)) 'TextString ))
  22.          (if (or (= (substr TextString 1 1) "k") (= (substr TextString 1 1) "K")) (setq TextString ""))
  23.       )
  24.       ((>= (sslength ob) 2)
  25.          (setq i 0 dislst nil)
  26.          (repeat (sslength ob)
  27.            (setq Name (ssname ob i))
  28.            (setq obj (vlax-ename->vla-object Name))
  29.            (setq isPt (Vlax-get obj 'InsertionPoint ))
  30.            (setq TextString (Vlax-Get obj 'TextString ))
  31.            (if (or (/= (substr TextString 1 1) "k") (/= (substr TextString 1 1) "K"))
  32.              (progn
  33.                (setq dist (list (distance pt isPt) TextString))
  34.                (setq dislst (cons dist dislst))
  35.              )
  36.            )
  37.            (setq i (1+ i))
  38.          )
  39.          (setq dislst (vl-sort dislst (function (lambda (a b) (< (car a) (car b))))))
  40.          (setq TextString (cadr (car dislst)))
  41.       )
  42.     )
  43.     TextString
  44.   )
  45.   (if (= (getvar "USERR1") 0.0)
  46.       (progn
  47.           (setq use (getint "\n绘图比例1:<200>"))
  48.           (if (= use nil) (setq use 200))
  49.           (setvar "USERR1" use)
  50.       )
  51.   )
  52.   (vl-load-com)
  53.   (setq use (getvar "USERR1"))
  54.   (setq osmode (getvar "osmode"))
  55.   (setvar "osmode" 0)
  56.   (setvar "cmdecho" 0)
  57.   (if (setq PL (car (entsel "\n请选择断面线：")))
  58.     (progn
  59.       (setq ob_PL (vlax-ename->vla-object PL))
  60.       (setq objname (Vlax-Get ob_pl 'ObjectName ))
  61.       (setvar "osmode" 33)
  62.       (setq zxd (getpoint "\n拾取断面起点：")
  63.             zxd (list (car zxd) (cadr zxd))
  64.       )
  65.       (setvar "osmode" 0)
  66.       (cond
  67.         ((= objname "AcDbLine")
  68.           (setq StartPt (Vlax-Get ob_pl 'StartPoint ))
  69.         )
  70.         ((= objname "AcDbPolyline")
  71.           (setq Ele (Vlax-Get ob_pl 'Elevation ))
  72.           (cond
  73.             ((/= Ele 0) (alert "请将断面线标高修改为0") (exit))
  74.             ((= Ele 0)
  75.               (setq ptlst (Vlax-Get ob_pl 'Coordinates ))
  76.               (setq StartPt (list (car ptlst) (cadr ptlst) 0))
  77.             )
  78.           )
  79.         )
  80.       )
  81.       (princ "\n选择和断面线高程点")
  82.       (setq lst nil)
  83.       (if (setq i -1 ss (ssget '((0 . "INSERT") (2 . "GC200"))))
  84.         (progn
  85.           (repeat (sslength ss)
  86.             (setq Name (ssname ss (setq i (1+ i))))
  87.             (setq pt (cdr (assoc 10 (entget Name))))
  88.             (setq lst (cons pt lst))
  89.           )
  90.           (setq lst (dmcj_gcdsort lst ob_PL)) ;高程点按曲线进行排序
  91.           (setq fistgcd (car lst))
  92.           (setq fistPt (vlax-curve-getClosestPointTo ob_PL fistgcd)) ;第一个高程点垂足断面线的坐标
  93.           (setq fistdist (distance zxd fistPt)) ;第一个高程点垂足断面线上的坐标点离断面线起点的距离
  94.           (if (null **Name) (setq **Name "D:\\K0+000"))
  95.           (if (setq file (getfiled "保存数据" **Name "csv" 1))
  96.             (progn
  97.               (setq FileName (vl-filename-base file))
  98.               (setq PathName (vl-filename-directory file))
  99.               (cond
  100.                 ((or (= PathName "C:\") (= PathName "D:\") (= PathName "E:\") (= PathName "F:\"))
  101.                    (setq msg (strcat PathName FileName))
  102.                 )
  103.                 ((or (/= PathName "C:\") (/= PathName "D:\") (/= PathName "E:\") (/= PathName "F:\"))
  104.                    (setq msg (strcat PathName "\" FileName))
  105.                 )
  106.               )
  107.               (if (null msg)
  108.                 (setq msg **Name) ;_回车后的返回值
  109.                 (setq **Name msg) ;_全局变量*real值，记忆为用户输入值
  110.               )
  111.               (setq file (open file "a"))
  112.               (write-line "距离,高程值,备注" file)
  113.               (foreach v lst
  114.                 (setq pt (vlax-curve-getClosestPointTo ob_PL v))
  115.                 (setq dist (- (vlax-curve-getDistAtPoint ob_PL pt) fistdist))
  116.                 (setq gcdz (caddr v))
  117.                 (setq str (dmcj_getstr (list (car pt) (cadr pt)) use)) ;注记
  118.                 (write-line (strcat (rtos dist 2 3) "," (rtos gcdz 2 3)  "," str) file)
  119.               )
  120.               (close file)
  121.             )
  122.           )
  123.         )
  124.       )
  125.     )
  126.   )
  127.   (setvar "osmode" osmode)
  128.   (princ)
  129. )

点评

情迷法兰西0
编程大牛  发表于 2017-1-17 08:07
树櫴希德
测绘精英  发表于 2015-6-15 11:30
回复 支持 反对

使用道具 举报

cuyongping
发表于 2013-6-2 11:39:50 | 显示全部楼层
谢谢gzxl 无私提供源码！
回复 支持 反对

使用道具 举报

gzbccy
发表于 2013-11-29 15:40:20 | 显示全部楼层
gzxl 发表于 2013-5-17 13:06
这么多人有兴趣啊

要是有个动态演示更加美好
回复 支持 反对

使用道具 举报

gzxl
发表于 2013-11-29 20:48:43 | 显示全部楼层
gzbccy 发表于 2013-11-29 15:40
要是有个动态演示更加美好


本帖子中包含更多资源

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

x

点评

skg123
挺好的，选取了断面线附近的高程点绘制断面图。  发表于 2015-4-20 20:05
回复 支持 反对

使用道具 举报

12345下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-15 06:44 , Processed in 0.164427 second(s), 23 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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