修改大神代码，横断面图转成高程点并导出

树櫴希德 · 发表于 2017-9-20 14:31:50

:D

;;;by Gu_xl
(defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)
(setvar "CMDECHO" 0)
(command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" "" "")
(if height
(setq height (rtos height 2 3));3为高程注记位数
(setq height "")
)
(regapp "SOUTH")
;;;检查字体 "HZ" 是否存在
(if (not (tblobjname "style" "HZ"))
(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
)
;;;检查是否存在高程点图块定义
(if (not (tblobjname "block" "GC200"))
(progn
(setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
(setq obj
(vla-AddPolyline
blkdef
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble (cons 0 5))
'(-0.2 0 0 0.2 0 0)
)
)
)
)
(vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
(vla-put-Closed obj :vlax-true)
(vla-put-ConstantWidth obj 0.4)
)
)
;;;插入块
(entmake (list
'(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1);;;属性跟随标志,1跟随，0不跟随
(cons 2 "GC200")
(cons 10 inspt)
(cons 41 scale)
(cons 42 scale)
(cons 43 scale)
(list -3 '("SOUTH" (1000 . "202101")))
)
)
;;;插入属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (setq pt (polar inspt 0 (* 1.2 scale))))
(cons 40 (* 2.0 scale))
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 height)
(cons 7 "HZ")
(cons 62 1)
(cons 72 0)
(cons 11 pt)
'(100 . "AcDbAttribute")
(cons 2 "height")
(cons 70 0)
(cons 74 2)
)
)
;;;结束标志
(entmake '((0 . "SEQEND")))
(princ)
)
;;;;;;;;;;;;;;;;;;;;
(defun c:tqdmsj()
(vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP
(setq blc (getint "\n请输入比例尺1:<500>"))
(if (= blc nil)(setq blc 500))
(setvar 'userr1 blc);设置比例尺
(setq scale (* 0.001 blc));缩放比例
(setq qszhxh (getint "\n请输入起始桩号-1后的序号：\n"))
(srcs_data)
(sjdc_data)
(princ (strcat "\n文件写至" ffn))
(prin1)
)
(defun srcs_data()
(setq ffn (getfiled "选取/建立数据导出文件" "" "hdm" 1))
(setq ff (open ffn "w"))
(close ff)
(setq hxbl (getint "\n请输入断面横向比例 1 :"))
(setq zxbl (getint "\n请输入断面纵向比例 1 :"))
)
(defun sjdc_data()
(alert "请选择需要导出数据的断面线")
(setq ss (ssget))
(setq ii 0)
(setq gcz 0.00)
(repeat (sslength ss)
(setq ssn (ssname ss ii))
(setq endata (entget ssn))
(setq zh (getstring (strcat "\n请输入第" (rtos (1+ ii) 2 3) "个断面的桩号:")))
(if (= zh "") (setq zh (1+ ii)))
(setq qd (getpoint "\n请输入该断面中桩点的位置:"))
(setq qdx (car qd)) (setq qdy (cadr qd))
(setq bak gcz)
(setq gcz (getreal (strcat "\n请输入中桩点的高程:<" (rtos bak 2 3) ">")))
(if (= gcz nil) (setq gcz bak))
(setq tmqd (getpoint "\n请输入该断面<平面图中>中桩点的位置:"))
(setq tmycfx (angle tmqd (getpoint "\n请输入该断面线<平面图中>右侧一点:") ))
(setq ff (open ffn "a"))
(princ "begin," ff) (princ zh ff) (princ ":" ff) (princ (rtos (1+ qszhxh) 2 3) ff) (princ "\n" ff) (close ff)
(tqzb_data)
(setq ii (1+ ii)) (setq qszhxh (1+ qszhxh))
)
(prin1)
)
(defun tqzb_data()
(setq nn 0)
(repeat (length endata)
(setq pp (nth nn endata))
(setq key (car pp))
(if (= key 10)
(progn
(setq xx (cadr pp)) (setq yy (caddr pp))
(setq dx (/ (- xx qdx) (/ 1000.000 hxbl)))
(setq dy (+ (/ (- yy qdy) (/ 1000.000 zxbl)) gcz) )
(setq xinzb (polar tmqd tmycfx dx))
(setq zxinzb (list (car xinzb) (cadr xinzb) dy))
(gxl-cs:gcd zxinzb dy scale)
(setq ff (open ffn "a"))
(princ (rtos dx 2 3) ff) (princ "," ff) (princ (rtos dy 2 3) ff) (princ "\n" ff)
(close ff)
)
)
(setq nn (1+ nn))
)
(prin1)
)
(prompt "提示：用<tqdmsj>命令来运行本程序")

;;;by Gu_xl 
(defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数) 
  (setvar "CMDECHO" 0) 
  (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "") 
  (if height 
    (setq height (rtos height 2 3));3为高程注记位数 
    (setq height "") 
  ) 
  (regapp "SOUTH") 
   
  ;;;检查字体 "HZ" 是否存在 
  (if (not (tblobjname "style" "HZ")) 
    (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "") 
  ) 
  ;;;检查是否存在高程点图块定义 
  (if (not (tblobjname "block" "GC200")) 
    (progn 
      (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200")) 
      (setq obj 
        (vla-AddPolyline 
           blkdef 
           (vlax-make-variant 
              (vlax-safearray-fill 
                 (vlax-make-safearray vlax-vbdouble (cons 0 5)) 
                 '(-0.2 0 0 0.2 0 0) 
              ) 
           ) 
        ) 
      ) 
      (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1) 
      (vla-put-Closed obj :vlax-true) 
      (vla-put-ConstantWidth obj 0.4) 
    ) 
  ) 
  ;;;插入块 
  (entmake (list 
             '(0 . "INSERT") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbBlockReference") 
             '(66 . 1);;;属性跟随标志,1跟随，0不跟随 
              (cons 2 "GC200") 
              (cons 10 inspt) 
              (cons 41 scale) 
              (cons 42 scale) 
              (cons 43 scale) 
              (list -3 '("SOUTH" (1000 . "202101"))) 
           ) 
  ) 
  ;;;插入属性 
  (entmake (list 
             '(0 . "ATTRIB") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbText") 
              (cons 10 (setq pt (polar inspt 0 (* 1.2 scale)))) 
              (cons 40 (* 2.0 scale)) 
              (cons 50 0) 
              (cons 41 0.8) 
              (cons 51 0) 
              (cons 1 height) 
              (cons 7 "HZ") 
       (cons 62 1) 
              (cons 72 0) 
              (cons 11 pt) 
              '(100 . "AcDbAttribute") 
              (cons 2 "height") 
              (cons 70  0) 
              (cons 74 2) 
           ) 
   ) 
   ;;;结束标志 
   (entmake '((0 . "SEQEND"))) 
   (princ) 
) 
 
;;;;;;;;;;;;;;;;;;;; 
 
 
(defun c:tqdmsj() 
  (vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP 
     (setq blc (getint "\n请输入比例尺1:<500>")) 
  (if (= blc nil)(setq blc 500)) 
  (setvar 'userr1 blc);设置比例尺 
(setq scale (* 0.001 blc));缩放比例 
   
  (setq qszhxh (getint "\n请输入起始桩号-1后的序号：\n")) 
(srcs_data) 
(sjdc_data) 
(princ (strcat "\n文件写至" ffn)) 
(prin1) 
) 
(defun srcs_data() 
  (setq ffn (getfiled "选取/建立数据导出文件" "" "hdm" 1)) 
  (setq ff (open ffn "w")) 
  (close ff) 
  (setq hxbl (getint "\n请输入断面横向比例 1 :")) 
  (setq zxbl (getint "\n请输入断面纵向比例 1 :")) 
) 
(defun sjdc_data() 
(alert "请选择需要导出数据的断面线") 
(setq ss (ssget)) 
(setq ii 0) 
(setq gcz 0.00) 
(repeat (sslength ss) 
    (setq ssn (ssname ss ii)) 
    (setq endata (entget ssn)) 
    (setq zh (getstring (strcat "\n请输入第" (rtos (1+ ii) 2 3) "个断面的桩号:"))) 
    (if (= zh "") (setq zh (1+ ii))) 
    (setq qd (getpoint "\n请输入该断面中桩点的位置:")) 
      (setq qdx (car qd)) (setq qdy (cadr qd)) 
    (setq bak gcz) 
    (setq gcz (getreal (strcat "\n请输入中桩点的高程:<" (rtos bak 2 3) ">"))) 
      (if (= gcz nil) (setq gcz bak)) 
(setq tmqd (getpoint "\n请输入该断面<平面图中>中桩点的位置:")) 
  (setq tmycfx (angle tmqd (getpoint "\n请输入该断面线<平面图中>右侧一点:") )) 
   
    (setq ff (open ffn "a")) 
    (princ "begin," ff) (princ zh ff) (princ ":" ff) (princ (rtos (1+ qszhxh) 2 3) ff) (princ "\n" ff) (close ff) 
    (tqzb_data) 
    (setq ii (1+ ii)) (setq qszhxh (1+ qszhxh)) 
) 
(prin1) 
)      
 
(defun tqzb_data() 
(setq nn 0) 
(repeat (length endata) 
   (setq pp (nth nn endata)) 
   (setq key (car pp)) 
   (if (= key 10) 
       (progn 
          (setq xx (cadr pp)) (setq yy (caddr pp)) 
          (setq dx (/ (- xx qdx) (/ 1000.000 hxbl))) 
          (setq dy (+ (/ (- yy qdy) (/ 1000.000 zxbl)) gcz) ) 
   (setq xinzb (polar tmqd tmycfx dx)) 
   (setq zxinzb (list (car xinzb) (cadr xinzb)  dy)) 
   (gxl-cs:gcd  zxinzb dy scale) 
          (setq ff (open ffn "a")) 
          (princ (rtos dx 2 3) ff) (princ "," ff) (princ (rtos dy 2 3) ff) (princ "\n" ff) 
          (close ff) 
         ) 
   ) 
   (setq nn (1+ nn)) 
) 
(prin1) 
) 
(prompt "提示：用<tqdmsj>命令来运行本程序")

wdjy808 · 发表于 2019-3-28 11:58:41

本帖最后由 wdjy808 于 2019-3-28 12:00 编辑

大神，我对你的这个插件进行了点简化，您输入的步骤有点多，现在只需要在C盘目录下，放一个文件（横断转点.dat）空白文件。不用去管横纵比例。
希望大神指正。
希望您加入批量转化功能

skg123 · 发表于 2019-3-6 13:28:46

本帖最后由 skg123 于 2019-3-6 13:38 编辑

看了演示，没有测试。
建议：程序设计成不用在中线上指定位置绘图，应该设计出成选好中线，后面的只要选择横断面线并输入横断面的里程，程序就自动在对应的中线上添加高程点，理由是点击中线上的位置，容易捕捉出错，对不是整桩的断面，找对应的位置很难，这个应该由程序推算精确的位置。免去往返中线与断面图这个动作，可提供效率。

血司 · 发表于 2017-9-20 14:49:42

这个6了，gxl-cs:gcd这个被你用烂了

spp_wall · 发表于 2017-9-21 08:30:22

厉害能批量把hdm的地面线数据导出么！

gzxl · 发表于 2017-9-21 16:45:46

ynpxqjlb · 发表于 2017-9-21 17:59:12

树櫴希德 · 发表于 2017-9-21 19:28:42

spp_wall 发表于 2017-9-21 08:30
厉害能批量把hdm的地面线数据导出么！

你试试吧应该可以

lizhigang.jin · 发表于 2017-9-24 14:37:34

不错，很不错的程序，

wu112031853 · 发表于 2017-9-25 22:02:28

很不错，谢谢！！！！

硕王 · 发表于 2017-10-15 10:35:11

树櫴希德发表于 2017-9-21 19:28
你试试吧应该可以

怎么显示字符串错误呢老兄

lifuq1979 · 发表于 2017-10-16 12:26:50

gxl-cs:gcd这个函数插入的高程点位Z值为0怎么破，高程值是正确的

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

修改大神代码，横断面图转成高程点并导出

本帖子中包含更多资源

相关帖子

本帖子中包含更多资源