等高线赋值函数

linshiyin2

谁能搞出这个效果的lisp，设置起始高程、步长、增减，拉线与之相交的多段线赋值高程，完成后所赋值高程的多段线改变颜色（蓝色），不设置起始高程，拉线时读取第一条线的高程值，填入起始高程。
步骤：
1拉线确定哪些多段线赋值，多段线有先后顺序
2读取第一条多段线高程，填入起始高程，dcl设置步长增减
3按顺序赋值z高程，同时改变多段线颜色，
4删除拉线。
ok

mpk023

qiuhaitao110 发表于 2013-11-5 17:04
我自己写的代码 可以计算计曲线 和首曲线 并区分

插件还在么，能不能分享一个，谢谢。1281125288@qq.com

Gu_xl

拉线改等高线高程

以下是核心源码，仅供学习参考，未提供全部自定义函数源码，自定义函数可去我的网盘下载函数库！

1. (defun c:EditElv (/   MKTMPDCL   P1   P2   SS
   
2.     LINE   POBJLIST   OBJ   H0   DLGCODE
   
3.     DCLFILE ECODE   poly COLOR act_img
   
4.    )
   
5.   ;;写对话框文件
   
6. (defun mkTmpDcl (/ tmpdcl f)
   
7.    (setq f (open (setq tmpdcl (VL-FILENAME-MKTEMP "tmp" "" ".dcl")) "w"))
   
8.    (foreach str '(
   
9.             "editelv:dialog {"
   
10.             "        label = \"高程设置参数 编制: Gu_xl\";"
    
11.             "    :row {"
    
12.             "        :column {"
    
13.             "            :edit_box {"
    
14.             "                key = \"startelv\" ;"
    
15.             "                label = \"起始高程:\" ;"
    
16.             "            }"
    
17.             "            :edit_box {"
    
18.             "                is_enabled = false ;"
    
19.             "                key = \"endelv\" ;"
    
20.             "                label = \"终止高程:\" ;"
    
21.             "            }"
    
22.             "            :edit_box {"
    
23.             "                key = \"delv\" ;"
    
24.             "                label = \"高程增量:\" ;"
    
25.             "            }"
    
26.             "            :row {"
    
27.             "                :text {"
    
28.             "                    label = \"修改后颜色:\" ;"
    
29.             "                }"
    
30.             "                :image_button {"
    
31.      "                    key = \"image\" ;"
    
32.             "                    width = 6 ;"
    
33.             "                    aspect_ratio = 0.5 ;"
    
34.             "                    fixed_height = true ;"
    
35.             "                    fixed_width = true ;"
    
36.             "                }"
    
37.             "                :edit_box {"
    
38.             "                    key = \"color\" ;"
    
39.             "                }"
    
40.             "            }"
    
41.             "        }"
    
42.             "        :column {"
    
43.             "            :row {"
    
44.             "                :radio_button {"
    
45.             "                    key = \"add\" ;"
    
46.             "                    label = \"增加:\" ;"
    
47.             "                }"
    
48.             "                :radio_button {"
    
49.             "                    key = \"sub\" ;"
    
50.             "                    label = \"减少:\" ;"
    
51.             "                }"
    
52.             "            }"
    
53.             "            ok_cancel;"
    
54.             "        }"
    
55.             "    }"
    
56.             "}"
    
57.    )
    
58.    (write-line str f)
    
59.   )
    
60.   (close f)
    
61.   tmpdcl
    
62. )
    
63.   ;;颜色选择动作
    
64. (defun act_img ( / color1)
    
65.   (setq color1 (ACAD_COLORDLG color))
    
66.   (if  color1
    
67.     (progn
    
68.       (setq color color1)
    
69.       (set_tile "color" (itoa color))
    
70.       (gxl-dcl-ImageFillColor "image" color)
    
71.       (setenv "EditElv_Color" (VL-PRINC-TO-STRING COLOR))
    
72.       )
    
73.     )
    
74.   )
    
75.   
    
76.   (setq endh 10000 ;_ 终止高程最大值
    
77.      flag t ;_ t = 高程增加 nil = 高程减小
    
78.       )
    
79.   (while
    
80.     (and (setq p1 (getpoint "\n第一点:"))
    
81.   (setq p2 (getpoint p1 "\n第二点:"))
    
82.   (setq ss (ssget "F" (list p1 p2) '((0 . "*polyline"))))
    
83.       )
    
84.       (setq line (GXL-AX:ADDLWPOLYLINE *MODEL-SPACE* (list p1 p2))) ;_ 绘制线
    
85.       (princ)
    
86.     ;;计算 line 和 ss 的交点
    
87.       (setq pobjlist
    
88.       (GXL-SEL-MAPCAR
    
89.         ss
    
90.         '(lambda (X / obj)
    
91.     (list (car (gxl-IntersWithLWP
    
92.           (setq obj (vlax-ename->vla-object x))
    
93.           line
    
94.           acExtendNone
    
95.         )
    
96.    )
    
97.    obj
    
98.     )
    
99.   )
    
100.       )
     
101.       )
     
102.     ;;交点排序
     
103.       (setq
     
104. pobjlist (vl-sort
     
105.      pobjlist
     
106.      '(lambda (a b)
     
107.         (< (distance p1 (car a)) (distance p1 (car b)))
     
108.       )
     
109.    )
     
110.       )
     
111.       (setq h0 (vla-get-elevation (cadar pobjlist))) ;_ 取第一根线为默认起始高程
     
112.       (if (setq dh (getEnv "EditElv_dh")) ;_ 取出默认高程增量值
     
113. (setq dh (read dh))
     
114. (progn
     
115. (setq dh 10)
     
116. (setenv "EditElv_dh" (VL-PRINC-TO-STRING dh))
     
117. )
     
118. )
     
119.       (if (setq COLOR (getEnv "EditElv_Color")) ;_ 取出默认修改颜色
     
120. (setq COLOR (read COLOR))
     
121. (progn
     
122. (setq COLOR 5)
     
123. (setenv "EditElv_Color" (VL-PRINC-TO-STRING COLOR))
     
124. )
     
125. )
     
126.       
     
127.       (setq dlgcode (LOAD_DIALOG (setq dclfile (mkTmpDcl)))) ;_ 加载对话框文件
     
128.       (vl-file-delete dclfile)
     
129.       (new_dialog "editelv" dlgcode) ;_ 启动对话框
     
130.       (gxl-dcl-ImageFillColor "image" color) ;_ 填充颜色图像控件
     
131.       (set_tile "startelv" (rtos h0 2 3)) ;_ 设置默认起始高程
     
132.       (set_tile "endelv" (rtos endh 2 3)) ;_  设置默认终止高程最大值
     
133.       (if flag (set_tile "add" "1") (set_tile "sub" "1")) ;_
     
134.       (set_tile "delv" (rtos dh 2 3))
     
135.       (set_tile "color" (itoa color))
     
136.       (action_tile
     
137. "startelv"
     
138. "(setq h0 (GXL-CHKREAL $value $key))"
     
139.       )
     
140.       (action_tile "image" "(act_img)")
     
141.       (action_tile "color" "(setq color (GXL-CHKINT $value $key))(if color (progn (gxl-dcl-ImageFillColor \"image\" color) (setenv \"EditElv_Color\" (VL-PRINC-TO-STRING COLOR))))")
     
142.       (action_tile "delv" "(setq dh (GXL-CHKREAL $value $key))(if dh (setenv \"EditElv_dh\" (VL-PRINC-TO-STRING dh)))")
     
143.       (action_tile "add" "(setq Flag t)(setq endh 10000) (set_tile \"endelv\" (rtos endh 2 3))")
     
144.       (action_tile "sub" "(setq Flag nil)(setq endh 0) (set_tile \"endelv\" (rtos endh 2 3))")
     
145.       (setq ecode (START_DIALOG))
     
146.       (if (= 1 ecode)
     
147. (progn
     
148.    (setq h h0)
     
149.    (foreach al pobjlist
     
150.      (if (or (and flag (< h endh))
     
151.       (and (not flag) (> h endh))
     
152.       )
     
153.        (progn
     
154.      (setq poly (cadr al))
     
155.      (vla-put-elevation poly h) ;_ 修改高程
     
156.      (vla-put-color poly color) ;_ 修改颜色
     
157.      (if flag
     
158.        (setq h (+ h dh))
     
159.        (setq h (- h dh))
     
160.      )
     
161.      )
     
162.        )
     
163.    )
     
164. )
     
165.       )
     
166.       (vla-delete line)
     
167.   )
     
168.   (princ)
     
169. )
     

(defun c:EditElv (/   MKTMPDCL   P1   P2   SS<br />     LINE   POBJLIST   OBJ   H0   DLGCODE<br />     DCLFILE ECODE   poly COLOR act_img <br />    )<br />   ;;写对话框文件<br /> (defun mkTmpDcl (/ tmpdcl f)<br />    (setq f (open (setq tmpdcl (VL-FILENAME-MKTEMP "tmp" "" ".dcl")) "w"))<br />    (foreach str '(<br />             "editelv:dialog {"<br />             "        label = \"高程设置参数 编制: Gu_xl\";"<br />             "    :row {"<br />             "        :column {"<br />             "            :edit_box {"<br />             "                key = \"startelv\" ;"<br />             "                label = \"起始高程:\" ;"<br />             "            }"<br />             "            :edit_box {"<br />             "                is_enabled = false ;"<br />             "                key = \"endelv\" ;"<br />             "                label = \"终止高程:\" ;"<br />             "            }"<br />             "            :edit_box {"<br />             "                key = \"delv\" ;"<br />             "                label = \"高程增量:\" ;"<br />             "            }"<br />             "            :row {"<br />             "                :text {"<br />             "                    label = \"修改后颜色:\" ;"<br />             "                }"<br />             "                :image_button {"<br />      "                    key = \"image\" ;"<br />             "                    width = 6 ;"<br />             "                    aspect_ratio = 0.5 ;"<br />             "                    fixed_height = true ;"<br />             "                    fixed_width = true ;"<br />             "                }"<br />             "                :edit_box {"<br />             "                    key = \"color\" ;"<br />             "                }"<br />             "            }"<br />             "        }"<br />             "        :column {"<br />             "            :row {"<br />             "                :radio_button {"<br />             "                    key = \"add\" ;"<br />             "                    label = \"增加:\" ;"<br />             "                }"<br />             "                :radio_button {"<br />             "                    key = \"sub\" ;"<br />             "                    label = \"减少:\" ;"<br />             "                }"<br />             "            }"<br />             "            ok_cancel;"<br />             "        }"<br />             "    }"<br />             "}"<br />    )<br />    (write-line str f)<br />   )<br />   (close f)<br />   tmpdcl<br /> )<br />   ;;颜色选择动作<br /> (defun act_img ( / color1)<br />   (setq color1 (ACAD_COLORDLG color))<br />   (if  color1<br />     (progn<br />       (setq color color1)<br />       (set_tile "color" (itoa color))<br />       (gxl-dcl-ImageFillColor "image" color)<br />       (setenv "EditElv_Color" (VL-PRINC-TO-STRING COLOR))<br />       )<br />     )<br />   )<br />   <br />   (setq endh 10000 ;_ 终止高程最大值<br />      flag t ;_ t = 高程增加 nil = 高程减小<br />       )<br />   (while<br />     (and (setq p1 (getpoint "\n第一点:"))<br />   (setq p2 (getpoint p1 "\n第二点:"))<br />   (setq ss (ssget "F" (list p1 p2) '((0 . "*polyline"))))<br />       )<br />       (setq line (GXL-AX:ADDLWPOLYLINE *MODEL-SPACE* (list p1 p2))) ;_ 绘制线<br />       (princ)<br />     ;;计算 line 和 ss 的交点<br />       (setq pobjlist<br />       (GXL-SEL-MAPCAR<br />         ss<br />         '(lambda (X / obj)<br />     (list (car (gxl-IntersWithLWP<br />           (setq obj (vlax-ename->vla-object x))<br />           line<br />           acExtendNone<br />         )<br />    )<br />    obj<br />     )<br />   )<br />       )<br />       )<br />     ;;交点排序<br />       (setq<br /> pobjlist (vl-sort<br />      pobjlist<br />      '(lambda (a b)<br />         (< (distance p1 (car a)) (distance p1 (car b)))<br />       )<br />    )<br />       )<br />       (setq h0 (vla-get-elevation (cadar pobjlist))) ;_ 取第一根线为默认起始高程<br />       (if (setq dh (getEnv "EditElv_dh")) ;_ 取出默认高程增量值<br /> (setq dh (read dh))<br /> (progn<br /> (setq dh 10)<br /> (setenv "EditElv_dh" (VL-PRINC-TO-STRING dh))<br /> )<br /> )<br />       (if (setq COLOR (getEnv "EditElv_Color")) ;_ 取出默认修改颜色<br /> (setq COLOR (read COLOR))<br /> (progn<br /> (setq COLOR 5)<br /> (setenv "EditElv_Color" (VL-PRINC-TO-STRING COLOR))<br /> )<br /> )<br />       <br />       (setq dlgcode (LOAD_DIALOG (setq dclfile (mkTmpDcl)))) ;_ 加载对话框文件<br />       (vl-file-delete dclfile)<br />       (new_dialog "editelv" dlgcode) ;_ 启动对话框<br />       (gxl-dcl-ImageFillColor "image" color) ;_ 填充颜色图像控件<br />       (set_tile "startelv" (rtos h0 2 3)) ;_ 设置默认起始高程<br />       (set_tile "endelv" (rtos endh 2 3)) ;_  设置默认终止高程最大值<br />       (if flag (set_tile "add" "1") (set_tile "sub" "1")) ;_ <br />       (set_tile "delv" (rtos dh 2 3))<br />       (set_tile "color" (itoa color))<br />       (action_tile<br /> "startelv"<br /> "(setq h0 (GXL-CHKREAL $value $key))"<br />       )<br />       (action_tile "image" "(act_img)")<br />       (action_tile "color" "(setq color (GXL-CHKINT $value $key))(if color (progn (gxl-dcl-ImageFillColor \"image\" color) (setenv \"EditElv_Color\" (VL-PRINC-TO-STRING COLOR))))")<br />       (action_tile "delv" "(setq dh (GXL-CHKREAL $value $key))(if dh (setenv \"EditElv_dh\" (VL-PRINC-TO-STRING dh)))")<br />       (action_tile "add" "(setq Flag t)(setq endh 10000) (set_tile \"endelv\" (rtos endh 2 3))")<br />       (action_tile "sub" "(setq Flag nil)(setq endh 0) (set_tile \"endelv\" (rtos endh 2 3))")<br />       (setq ecode (START_DIALOG))<br />       (if (= 1 ecode)<br /> (progn<br />    (setq h h0)<br />    (foreach al pobjlist<br />      (if (or (and flag (< h endh))<br />       (and (not flag) (> h endh))<br />       )<br />        (progn<br />      (setq poly (cadr al))<br />      (vla-put-elevation poly h) ;_ 修改高程<br />      (vla-put-color poly color) ;_ 修改颜色<br />      (if flag<br />        (setq h (+ h dh))<br />        (setq h (- h dh))<br />      )<br />      )<br />        )<br />    )<br /> )<br />       )<br />       (vla-delete line)<br />   )<br />   (princ)<br /> )<br />

roger628364

版主你好！谢谢支援！

linshiyin2

老大给力啊，程序不错，请教一下，如何通过拉线顺序获取对象呢，知道这个就好办了啊，

yoyoho

等高线比较少碰触领域,学习一下咯!

linshiyin2008

2. (defun C:gcfz(/ p1 p2 ss)
   
3.   (setvar "blipmode" 0)
   
4.   (initget 1)
   
5.   (setq p1 (getpoint "\n第1点:"))                ;给出第一点
   
6.   (initget 1)
   
7.   (setq p2 (getpoint p1 "\n第2点:"))           ;给出第二点
   
8.   (setq ss (ssget "F" (list p1 p2) '((0 . "*polyline"))))
   
9.   (while (setq ed (car ss));;;返回表中的第一个元素
   
10.     (setq ed (entget en1))
    
11.     (setq ed (subst (cons 10 bg) (assoc 10 ed) ed ));;;修改高程z
    
12.     (setq ed (subst (cons 62 "5") (assoc 62 ed) ed ));;;改成蓝色
    
13.     (entmod ed)
    
14.     (setq ss (cdr ss));;;剩下的元素
    
15.     )
    
16.   );;;end gcfz
    
17. (defun getdata( / );;获取dcl数值
    
18.   
    
19. )
    
20. (defun readdata( / );;返回第一对象的z高程数值并传给dcl
    
21.   
    
22. )

(defun C:gcfz(/ p1 p2 ss)<br />   (setvar "blipmode" 0)<br />   (initget 1)<br />   (setq p1 (getpoint "\n第1点:"))                ;给出第一点<br />   (initget 1)<br />   (setq p2 (getpoint p1 "\n第2点:"))           ;给出第二点<br />   (setq ss (ssget "F" (list p1 p2) '((0 . "*polyline"))))<br />   (while (setq ed (car ss));;;返回表中的第一个元素<br />     (setq ed (entget en1))<br />     (setq ed (subst (cons 10 bg) (assoc 10 ed) ed ));;;修改高程z<br />     (setq ed (subst (cons 62 "5") (assoc 62 ed) ed ));;;改成蓝色<br />     (entmod ed)<br />     (setq ss (cdr ss));;;剩下的元素<br />     )<br />   );;;end gcfz<br /> (defun getdata( / );;获取dcl数值<br />   <br /> )<br /> (defun readdata( / );;返回第一对象的z高程数值并传给dcl<br />   <br /> )

自己写的，累了写不下去了

kkk3kkk

等高线比较少用good

sachindkini

dear sir

nice

sy100

进来向各位学习了。。。

自贡黄明儒

看看G版的是否满足楼主要求了？