★★★★★求高手完善下这个程序！提取完数据后再复制一遍★★★★★

spp_wall

       完善下面这个程序   

1.现在点取距离没问题 但是有时候输入距离会出问题      是否能实现手输入距离和点取距离都不出现问题
2.每次提取完数据后自动复制一次数据

	起止桩号	中分带	行车道	附加车道	硬路肩	土路肩
起点	0	0	16.5	0	0	0
终点	107.977	0	16.5	0	0	0
起点	107.977	0	16.5	0	0	0
终点	137.977	0	11.5	0	0	0

3：如果能实现提取距离前提示  那就更完美了  提示上面的 中分带、行车道、附加车道、硬路肩、土路肩 然后再提取距离或者手工输入距离   如果是没有就手输入0记录下来

vectra

1. (vl-load-com)
   
2. 
   
3. (defun c:wid (/        a ang ang2 e en        fh file        len leng leng1 leng2 lst nn1 nn2 obj old_lay perpt pt pt0
   
4.               pt1 pt2 pt4 px pxy py str_1) ;桩号查询
   
5.   (prompt "2013-9-22  vectra 待兔  惠州路桥 2010-07-27 zo roo  CGGC 武赤公路")
   
6.   (prompt "*查询线路任意点桩号* << C:zhcx>> *计算中桩坐标*")
   
7.   (setq old_lay (getvar "clayer"))
   
8.   (if (= (tblobjname "LAYER" "桩号标注") nil)
   
9.     (progn
   
10.       (entmake (list
    
11.                  '(0 . "LAYER")
    
12.                  '(100 . "AcDbSymbolTableRecord")
    
13.                  '(100 . "AcDbLayerTableRecord")
    
14.                  '(6 . "CONTINUOUS")
    
15.                  '(62 . 3)
    
16.                  '(70 . 0)
    
17.                  (cons 2 "桩号标注")
    
18.                )
    
19.       )
    
20.     )
    
21.   )
    
22.   (setvar "clayer" "桩号标注")
    
23.   (setq        en (entsel "\n选择道路中心线: ")
    
24.         a  (getreal "\n请输入起点桩号:")
    
25.         e  (car en)
    
26.         pt (cadr en)
    
27.   )
    
28.   (if (setq len (getreal "\n输入垂线长度(道路半幅宽):")) ;此处要加入非法输入的控制
    
29.     (progn
    
30.       (setq obj (vlax-ename->vla-object (car en)))
    
31.     )
    
32.   )
    
33. 
    
34.   ;; A1 追加方式打开保存文件
    
35.   (if (null filename)
    
36.     (setq filename (getfiled
    
37.                      "保存到文件"
    
38.                      (strcat (getvar "dwgprefix")
    
39.                              (vl-filename-base (getvar "dwgname"))
    
40.                      )
    
41.                      "txt"
    
42.                      1
    
43.                    )
    
44.     )
    
45.   )
    
46.   (setq file (open filename "a"))
    
47.   (setvar "DIMZIN" 0)
    
48. 
    
49. 
    
50. 
    
51.   (while (setq pt0 (getpoint "\n选择查询点："))
    
52.                                         ;画曲线的垂线
    
53.     (setq perpt        (vlax-curve-getclosestpointto obj pt0 t)
    
54.           lst        (vlax-curve-getfirstderiv obj (vlax-curve-getparamatpoint obj perpt))
    
55.           ang        (atan (/ (cadr lst) (car lst)))
    
56.           pt1        (polar perpt (+ ang (* 0.5 pi)) len)
    
57.           pt2        (polar perpt (- ang (* 0.5 pi)) len)
    
58.                                         ;此处就是你画出来的是水平线的原因，变量换个方向即可
    
59.     )
    
60.     (setq ang2 (angtos (angle pt2 pt1) 0 4))
    
61.     (command "pline" pt1 pt2 "")
    
62.                                         ;计算桩号
    
63.     (setq leng        (vlax-curve-getdistatparam e (vlax-curve-getendparam e))
    
64.           leng1        (+ a (vlax-curve-getdistatpoint e perpt))
    
65.           leng2        (- leng leng1)
    
66.     )
    
67.                                         ;计算桩号
    
68.     (if        (< leng1 0.0)
    
69.       (setq fh "-")
    
70.       (setq fh "+")
    
71.     )
    
72.     (setq nn1 (fix (/ leng1 1000.0)))
    
73.     (setq nn2 (abs (- leng1 (* 1000.0 nn1))))
    
74.     (if        (= nn2 0.0)
    
75.       (setq str_1 (strcat fh "00"))
    
76.     )
    
77.     (if        (and (> nn2 0) (< nn2 10.0))
    
78.       (setq str_1 (strcat (strcat fh "00") (rtos nn2 2 3)))
    
79.     )
    
80.     (if        (and (> nn2 10.0) (< nn2 100.0))
    
81.       (setq str_1 (strcat (strcat fh "0") (rtos nn2 2 3)))
    
82.     )
    
83.     (if        (>= nn2 100.0)
    
84.       (setq str_1 (strcat fh (rtos nn2 2 3)))
    
85.     )
    
86. 
    
87.     (setq str_1 (strcat "K" (rtos nn1 2 0) "+" (rtos nn2 2 3)))
    
88.     (setq pt4 (polar pt1 (+ (* pi 0.45) ang) (* -2 (* 1.65406 0.67))))
    
89.     (command "text" "j" "MC" pt4 "0.3" ang2 str_1)
    
90. 
    
91.     ;; A2 保存数据
    
92.     (setq strout (rtos leng1 2 3))
    
93.     (get-distance "中分带" 'wid-dist1 'strout)
    
94.     (get-distance "行车道" 'wid-dist2 'strout)
    
95.     (get-distance "附加车道" 'wid-dist3 'strout)
    
96.     (get-distance "硬路肩" 'wid-dist4 'strout)
    
97.     (get-distance "土路肩" 'wid-dist5 'strout)
    
98.     (write-line strout file)
    
99.     (write-line strout file)
    
100. 
     
101.     (setq py (rtos (nth 0 pt0)))        ;提取测量坐标系Y值
     
102.     (setq px (rtos (nth 1 pt0)))        ;提取测量坐标洗X值
     
103.     (setq pxy (strcat str_1 "中桩坐标：X=" px ",Y=" py))
     
104.     (princ pxy)
     
105.   )
     
106. 
     
107.   ;; A3 关闭文件
     
108.   (close file)
     
109.   (princ)
     
110. )
     
111. 
     
112. (defun get-distance (msg default buffer / dist)
     
113.   (if (null (vl-symbol-value default))
     
114.     (set default 0.0)
     
115.   )
     
116.   (setq dist (getdist (strcat "\n输入" msg "距离 <" (rtos (vl-symbol-value default) 2 2) ">:")))
     
117.   (if (null dist)
     
118.     (setq dist (vl-symbol-value default))
     
119.     (set default dist)
     
120.   )
     
121.   (set buffer (strcat (vl-symbol-value buffer) "\t" (rtos dist 2 2)))
     
122. )

(vl-load-com)<br /> <br /> (defun c:wid (/        a ang ang2 e en        fh file        len leng leng1 leng2 lst nn1 nn2 obj old_lay perpt pt pt0<br />               pt1 pt2 pt4 px pxy py str_1) ;桩号查询<br />   (prompt "2013-9-22  vectra 待兔  惠州路桥 2010-07-27 zo roo  CGGC 武赤公路")<br />   (prompt "*查询线路任意点桩号* << C:zhcx>> *计算中桩坐标*")<br />   (setq old_lay (getvar "clayer"))<br />   (if (= (tblobjname "LAYER" "桩号标注") nil)<br />     (progn<br />       (entmake (list<br />                  '(0 . "LAYER")<br />                  '(100 . "AcDbSymbolTableRecord")<br />                  '(100 . "AcDbLayerTableRecord")<br />                  '(6 . "CONTINUOUS")<br />                  '(62 . 3)<br />                  '(70 . 0)<br />                  (cons 2 "桩号标注")<br />                )<br />       )<br />     )<br />   )<br />   (setvar "clayer" "桩号标注")<br />   (setq        en (entsel "\n选择道路中心线: ")<br />         a  (getreal "\n请输入起点桩号:")<br />         e  (car en)<br />         pt (cadr en)<br />   )<br />   (if (setq len (getreal "\n输入垂线长度(道路半幅宽):")) ;此处要加入非法输入的控制<br />     (progn<br />       (setq obj (vlax-ename->vla-object (car en)))<br />     )<br />   )<br /> <br />   ;; A1 追加方式打开保存文件<br />   (if (null filename)<br />     (setq filename (getfiled<br />                      "保存到文件"<br />                      (strcat (getvar "dwgprefix")<br />                              (vl-filename-base (getvar "dwgname"))<br />                      )<br />                      "txt"<br />                      1<br />                    )<br />     )<br />   )<br />   (setq file (open filename "a"))<br />   (setvar "DIMZIN" 0)<br /> <br /> <br /> <br />   (while (setq pt0 (getpoint "\n选择查询点："))<br />                                         ;画曲线的垂线<br />     (setq perpt        (vlax-curve-getclosestpointto obj pt0 t)<br />           lst        (vlax-curve-getfirstderiv obj (vlax-curve-getparamatpoint obj perpt))<br />           ang        (atan (/ (cadr lst) (car lst)))<br />           pt1        (polar perpt (+ ang (* 0.5 pi)) len)<br />           pt2        (polar perpt (- ang (* 0.5 pi)) len)<br />                                         ;此处就是你画出来的是水平线的原因，变量换个方向即可<br />     )<br />     (setq ang2 (angtos (angle pt2 pt1) 0 4))<br />     (command "pline" pt1 pt2 "")<br />                                         ;计算桩号<br />     (setq leng        (vlax-curve-getdistatparam e (vlax-curve-getendparam e))<br />           leng1        (+ a (vlax-curve-getdistatpoint e perpt))<br />           leng2        (- leng leng1)<br />     )<br />                                         ;计算桩号<br />     (if        (< leng1 0.0)<br />       (setq fh "-")<br />       (setq fh "+")<br />     )<br />     (setq nn1 (fix (/ leng1 1000.0)))<br />     (setq nn2 (abs (- leng1 (* 1000.0 nn1))))<br />     (if        (= nn2 0.0)<br />       (setq str_1 (strcat fh "00"))<br />     )<br />     (if        (and (> nn2 0) (< nn2 10.0))<br />       (setq str_1 (strcat (strcat fh "00") (rtos nn2 2 3)))<br />     )<br />     (if        (and (> nn2 10.0) (< nn2 100.0))<br />       (setq str_1 (strcat (strcat fh "0") (rtos nn2 2 3)))<br />     )<br />     (if        (>= nn2 100.0)<br />       (setq str_1 (strcat fh (rtos nn2 2 3)))<br />     )<br /> <br />     (setq str_1 (strcat "K" (rtos nn1 2 0) "+" (rtos nn2 2 3)))<br />     (setq pt4 (polar pt1 (+ (* pi 0.45) ang) (* -2 (* 1.65406 0.67))))<br />     (command "text" "j" "MC" pt4 "0.3" ang2 str_1)<br /> <br />     ;; A2 保存数据<br />     (setq strout (rtos leng1 2 3))<br />     (get-distance "中分带" 'wid-dist1 'strout)<br />     (get-distance "行车道" 'wid-dist2 'strout)<br />     (get-distance "附加车道" 'wid-dist3 'strout)<br />     (get-distance "硬路肩" 'wid-dist4 'strout)<br />     (get-distance "土路肩" 'wid-dist5 'strout)<br />     (write-line strout file)<br />     (write-line strout file)<br /> <br />     (setq py (rtos (nth 0 pt0)))        ;提取测量坐标系Y值<br />     (setq px (rtos (nth 1 pt0)))        ;提取测量坐标洗X值<br />     (setq pxy (strcat str_1 "中桩坐标：X=" px ",Y=" py))<br />     (princ pxy)<br />   )<br /> <br />   ;; A3 关闭文件<br />   (close file)<br />   (princ)<br /> )<br /> <br /> (defun get-distance (msg default buffer / dist)<br />   (if (null (vl-symbol-value default))<br />     (set default 0.0)<br />   )<br />   (setq dist (getdist (strcat "\n输入" msg "距离 <" (rtos (vl-symbol-value default) 2 2) ">:")))<br />   (if (null dist)<br />     (setq dist (vl-symbol-value default))<br />     (set default dist)<br />   )<br />   (set buffer (strcat (vl-symbol-value buffer) "\t" (rtos dist 2 2)))<br /> )

清风明月名字

"每次提取完数据后自动复制一次数据“这句话是什么意思？

清风明月名字

我试 了，上面的代码很好用啊，可以用来读钻孔里程及偏移

spp_wall

清风明月名字 发表于 2013-9-28 12:57
"每次提取完数据后自动复制一次数据“这句话是什么意思？

现在的格式  不太符合我需要的格式

我想把每次提取的桩号和距离 重复一次

比如   

现在的桩号只是每一段道路的起点的桩号  我的数据还需要每段的终点桩号  

而这个终点桩号  其实就是下一段道路的起点桩号   

所以把每次提取的桩号和距离 重复一遍  就可以完成了

spp_wall

vectra 发表于 2013-9-28 11:00

谢谢！！！！！！