明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 7475|回复: 23

随机等高线加高程

[复制链接]
发表于 2017-8-3 09:21:51 | 显示全部楼层 |阅读模式
本帖最后由 树櫴希德 于 2017-8-23 20:54 编辑

  1. <div class="blockcode"><blockquote>(defun lst-(l1 l2)
  2. (vl-remove-if'(lambda(x)(member x l2))l1))

  3. (defun deld(lst d / a b c)
  4.   (while(setq a(mapcar'+(car lst)'(0 0))
  5.         b(vl-remove-if'(lambda(x)(>(distance a x)d))(cdr lst))
  6.         lst(lst-(cdr lst)b))
  7.     (setq c(cons b c))
  8.     )
  9.   (apply'append c))



  10. (defun gcpzx (pt ss / pt ss k pzx name pt pl p2 pzx1 kk Name1 pzx2 pzx3 gcc juli1 juli2 bz xgc xzb)
  11. ;(setq PT(getPOINT "\n请点击点:"))
  12. ;(setq dgj(getreal "\n请输入等高距:"))

  13. ;(setq ss (ssget '((0 . "POLYLINE") (8 . "DSX,DGX"))))

  14. (if ss
  15. (progn
  16.   (setq k -1)
  17. (setq pl '())
  18. (repeat (sslength ss)
  19.                (setq Name   (ssname ss (setq k (1+ k)))                       )
  20. (setq pzx(distance (vl-remove  (last pt) pt)  (vl-remove  (last (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name) PT [extend])) (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name) PT [extend]))
  21.    ))
  22.   (setq pl (append pl (list pzx)))
  23. ) (setq p2 (vl-sort pl '<))

  24.   
  25.   );;;;
  26.   
  27.   );;;;;;===========
  28.   (if ss
  29. (progn
  30.   (setq kk -1)

  31. (repeat (sslength ss)
  32.                (setq Name1   (ssname ss (setq kk (1+ kk)))                       )
  33.   (setq pzx1(distance (vl-remove  (last pt) pt)  (vl-remove  (last (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name1) PT [extend])) (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name1) PT [extend]))
  34.    ))
  35.   (cond
  36.   ((equal (car p2) pzx1 0.001) (setq pzx2 (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name1) PT [extend]))
  37.    )
  38.   ((equal (cadr p2) pzx1 0.001) (setq pzx3 (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name1) PT [extend]))
  39.    )
  40.     )
  41. )
  42. (setq gcc (- (last pzx2) (last pzx3)))
  43.   (setq juli1 (distance (vl-remove (last pzx2) pzx2) (vl-remove (last pzx3) pzx3)   ))
  44.   (setq juli2 (distance (vl-remove (last pt) pt) (vl-remove (last pzx3) pzx3)   ))
  45.   (setq bz (/ gcc juli1))
  46.   (setq xgc (+ (last pzx3)(* bz juli2) ))
  47.   (setq xzb (list (car pt) (cadr pt) xgc))
  48.   );;;;
  49.   
  50.   );;;;;;===========


  51. xzb

  52. );;;;;;;----------------------------------


  53. ;;;by Gu_xl
  54. (defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)
  55.   (setvar "CMDECHO" 0)
  56.   (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "")
  57.   (if height
  58.     (setq height (rtos height 2 3));3为高程注记位数
  59.     (setq height "")
  60.   )
  61.   (regapp "SOUTH")
  62.   
  63.   ;;;检查字体 "HZ" 是否存在
  64.   (if (not (tblobjname "style" "HZ"))
  65.     (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
  66.   )
  67.   ;;;检查是否存在高程点图块定义
  68.   (if (not (tblobjname "block" "GC200"))
  69.     (progn
  70.       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
  71.       (setq obj
  72.         (vla-AddPolyline
  73.            blkdef
  74.            (vlax-make-variant
  75.               (vlax-safearray-fill
  76.                  (vlax-make-safearray vlax-vbdouble (cons 0 5))
  77.                  '(-0.2 0 0 0.2 0 0)
  78.               )
  79.            )
  80.         )
  81.       )
  82.       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
  83.       (vla-put-Closed obj :vlax-true)
  84.       (vla-put-ConstantWidth obj 0.4)
  85.     )
  86.   )
  87.   ;;;插入块
  88.   (entmake (list
  89.              '(0 . "INSERT")
  90.              '(100 . "AcDbEntity")
  91.              '(100 . "AcDbBlockReference")
  92.              '(66 . 1);;;属性跟随标志,1跟随,0不跟随
  93.               (cons 2 "GC200")
  94.               (cons 10 inspt)
  95.               (cons 41 scale)
  96.               (cons 42 scale)
  97.               (cons 43 scale)
  98.               (list -3 '("SOUTH" (1000 . "202101")))
  99.            )
  100.   )
  101.   ;;;插入属性
  102.   (entmake (list
  103.              '(0 . "ATTRIB")
  104.              '(100 . "AcDbEntity")
  105.              '(100 . "AcDbText")
  106.               (cons 10 (setq pt (polar inspt 0 (* 1.2 scale))))
  107.               (cons 40 (* 2.0 scale))
  108.               (cons 50 0)
  109.               (cons 41 0.8)
  110.               (cons 51 0)
  111.               (cons 1 height)
  112.               (cons 7 "HZ")
  113.        (cons 62 1)
  114.               (cons 72 0)
  115.               (cons 11 pt)
  116.               '(100 . "AcDbAttribute")
  117.               (cons 2 "height")
  118.               (cons 70  0)
  119.               (cons 74 2)
  120.            )
  121.    )
  122.    ;;;结束标志
  123.    (entmake '((0 . "SEQEND")))
  124.    (princ)
  125. )

  126. ;;;;;;;;;;;;;;;;;;;;
  127. (defun RandList (a b n i / l r Rani)
  128.   (defun Rani (a b / tmp)
  129.     (if        (not *Seed*)
  130.       (setq *Seed* (- (setq tmp (getvar "DATE")) (fix tmp)))
  131.     )
  132.     (+ a
  133.        (fix (* (- b a)
  134.                (setq
  135.                  *Seed*        (- (setq
  136.                              tmp (/ (* *Seed* 1000000000 663608941)
  137.                                     1000000000.0
  138.                                  )
  139.                            )
  140.                            (fix tmp)
  141.                         )
  142.                )
  143.             )
  144.        )
  145.     )
  146.   )
  147.   (cond
  148.     ((or
  149.        (and (> (rem n (1+ (- b a))) 0)
  150.             (< i (1+ (/ n (1+ (- b a)))))
  151.        )
  152.        (and (= (rem n (1+ (- b a))) 0)
  153.             (< i (/ n (1+ (- b a))))
  154.        )
  155.      )
  156.      (prompt "\n没有满足要求的结果")
  157.     )
  158.     ((and (= (rem n (1+ (- b a))) 0)
  159.           (= i (/ n (1+ (- b a))))
  160.      )
  161.      (repeat i
  162.        (setq l (cons a l))
  163.      )
  164.      (while (< a b)
  165.        (setq a (1+ a))
  166.        (repeat i
  167.          (setq l (cons a l))
  168.        )
  169.      )
  170.      (reverse l)
  171.     )
  172.     (t
  173.      (while (< (length l) n)
  174.        (setq r (Rani a b))
  175.        (if (< (- (length l) (length (vl-remove r l))) i)
  176.          (setq l (cons r l))
  177.        )
  178.      )
  179.      (reverse l)
  180.     )
  181.   )
  182. )
  183. ;;测试: (f 1 100 40 1)
  184. (defun rand(low top / a b)
  185.   (setq a(last(assoc(type low)'((int atoi)(real atof))))
  186. b(+(*(- top low)(/(apply a(list(substr(rtos(getvar "cputicks"))8 3)))1000.))low)
  187. b(if(equal a'atoi)(fix b)b))
  188.   )
  189. ;;;;;;;;;;;;;;;;;;;;;;;
  190. (defun poinpl(p pt);;:点是否在指定点表内
  191.   (equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8))
  192. (defun plinexy(e)
  193.   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))
  194.   )

  195. (defun c:sjgcd ( / ent11 pts ptlst ptlst1 e1 e2 minzb maxzb blc scale a b c n shuijishu i xzb yzb xinzb pzx123 xx)
  196. (setq ent11 (car (entsel "\n请选择边界线:")))
  197.   (prompt "\n请选择等高线:")
  198. (setq ss (ssget '((0 . "POLYLINE") (8 . "DSX,DGX"))))
  199. (setq pts (plinexy ent11))
  200. ;(setq zfu (poinpl (getpoint "\n.......") pts))
  201. (setq ptlst (vl-sort pts
  202.                    ;以下根据y坐标对表排序
  203.    '(lambda (e1 e2)
  204.             (< (cadr e1) (cadr e2) )
  205.          )   )    )

  206. (setq ptlst1 (vl-sort pts
  207.                    ;以下根据x坐标对表排序
  208.    '(lambda (e1 e2)
  209.             (< (car e1) (car e2) )
  210.          )   )    )

  211. (setq minzb (list (car(car ptlst1))  (cadr(car ptlst))                  )    )
  212. (setq maxzb (list (car(last ptlst1))  (cadr(last ptlst))                  )    )
  213. ;(command "rectangle" minzb maxzb)
  214.   (vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP
  215.      (setq blc (getint "\n请输入比例尺1:<500>"))
  216.   (if (= blc nil)(setq blc 500))
  217.   (setvar 'userr1 blc);设置比例尺
  218. (setq scale (* 0.001 blc));缩放比例
  219. ;(setq a (getreal "\n随机数下限(不要超过3位小数):"))
  220.           ; (setq b (getreal "\n随机数上限(不要超过3位小数):"))
  221.            (setq c (getint "\n随机数个数:"))
  222.            (setq n (getint "\n随机数最多重复次数:"))
  223. ;(command "_.units" "2" "8" "1" "8"  "0" "n")
  224. ;(princ)
  225. ;(setvar "dimzin" 8)

  226. ;(setq shuijishu (RandList  (* a (expt 10 3)) (* b (expt 10 3))  c n) )
  227. ; (setvar "dimzin" 0)

  228. (setq i 0)(setq pzx123 '())
  229. (repeat c

  230. (if   (and (setq xzb (car(randlist (* (atof (rtos (car minzb)2 3 ) )  1000) (* (atof (rtos (car maxzb)2 3 ) )  1000)  c n) ))
  231.             (setq yzb (car(randlist (* (atof (rtos (cadr minzb)2 3 ) )  1000) (* (atof (rtos (cadr maxzb)2 3 ) )  1000)  c n) ))
  232.    (= (poinpl (list (/ xzb 1000) (/ yzb 1000) ) pts)  T)
  233.    )
  234.    (progn
  235. (setq xinzb (gcpzx (list (/ xzb 1000) (/ yzb 1000) 0.000  ) ss))
  236. (setq pzx123 (append (list xinzb) pzx123)  )
  237.    
  238.    (setq i (1+ i))
  239.    ) )
  240.     )
  241.   (foreach xx (lst- pzx123 (deld pzx123 5.0000))

  242.     (gxl-cs:gcd  xx (last xx) scale)

  243.     )
  244.   
  245. (princ)
  246. )















































本帖子中包含更多资源

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

x
发表于 2017-8-10 06:56:25 | 显示全部楼层
我觉得不好,等高线还得依靠高程点,先后次序不能变,大多数情况下高程点不会丢失!
回复 支持 1 反对 0

使用道具 举报

发表于 2017-8-11 12:02:12 来自手机 | 显示全部楼层
lizhigang.jin 发表于 2017-8-3 15:28
命令: (LOAD "C:/Users/Administrator/Desktop/新建文本文档.lsp") ; 错误: no
function definition: 不 ...

你这个我提我也遇到了,请问你解决了吗?
发表于 2017-8-8 17:02:11 | 显示全部楼层
命令: (LOAD "C:/Users/Administrator/Desktop/新建文本文档.lsp") ; 错误: no
function definition: 不要超过3位小数
发表于 2017-8-3 10:15:52 | 显示全部楼层
赞个赞个,就是有一点,加出来的点,分布可以在优化一下
发表于 2017-8-3 15:28:06 | 显示全部楼层
命令: (LOAD "C:/Users/Administrator/Desktop/新建文本文档.lsp") ; 错误: no
function definition: 不要超过3位小数
发表于 2017-8-5 20:13:33 | 显示全部楼层
楼主又出山了
发表于 2017-8-6 14:37:55 | 显示全部楼层
非常感谢!!我需要高程值小数点后两位数,搞半天终于明白是RTOS这个函数
发表于 2017-8-7 08:09:29 | 显示全部楼层
非常感谢,拷贝下来学习学习
发表于 2017-8-7 08:22:03 | 显示全部楼层
要随贴测试dwg文件
发表于 2017-8-8 17:04:39 | 显示全部楼层
血司 发表于 2017-8-3 10:15
赞个赞个,就是有一点,加出来的点,分布可以在优化一下

怎么用的?我这边提示错误的
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-6 08:18 , Processed in 0.191308 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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