发了个动态桩号标注的程序，望高手不吝赐教

newbuser

以此抛出个茅坑又脏又硬的砖头，希望引来更多的美玉。现将小程序发于此处，程序运行过程中扔有些瑕疵，正如gif动画中在圆上标注桩号时演示的那样，程序总是在无键盘和鼠标左右键交互的指令下自动终止，还请高手多多指教，鄙人愿闻其详。此程序仍需完善，比如加入捕捉或者循环标注等功能。还望高手不吝赐教啊。

2. (defun c:zh (/ os e obj  loop el  code mod val p l K m mstr ptmun  m.back
   
3.          plist)
   
4.   (setq dim (getvar "DIMZIN"))
   
5.   (setq unt (getvar "UNITMODE"))
   
6.   (setvar "DIMZIN" 0)
   
7.   (setvar "UNITMODE" 0)
   
8.   (setq os (getvar "osmode"))
   
9.   (setq e (car (entsel "\n 请选择需要标注的多段线=>> ")))
   
10.   (prompt "\n <<****欢迎使用逐桩标注程序****>>")
    
11.   (setq obj (vlax-ename->vla-object e))
    
12.   (entmake (list '(0 . "TEXT")
    
13.      (cons 1 "0")
    
14.      '(10 0 0 0)
    
15.      (cons 40 1)
    
16.      (cons 62 3)
    
17.      (cons 8 "桩号标注")
    
18.      )
    
19.   )
    
20.   (setq el (entget (entlast)))
    
21. ;;;  (setq p (getpoint "\n 请选择需要标注的点位 "))
    
22.   (setq loop T)
    
23.   (while loop
    
24.     (setq code (grread T 4 1)
    
25.     mod  (car code)
    
26.     val  (cadr code)
    
27.     )
    
28.     (cond ((= 5 mod)
    
29.      ;;获取离曲线最近的点
    
30.      (setq p (vlax-curve-getClosestPointTo
    
31.          obj
    
32.          val
    
33.        )
    
34.      )
    
35.      (redraw)
    
36.      (grdraw val p 3)
    
37.      ;;指定点到起点的距离
    
38.      (setq l (vlax-curve-getDistAtPoint obj p)
    
39.      K (fix (* 0.001 l))
    
40.      m (- (* 0.001 l) K)
    
41.      )
    
42.      (setq mstr (rtos m 2 6))
    
43.      (setq ptnum (vl-string-search "." mstr))
    
44.      (setq m.back (substr mstr (+ 5 ptnum) 3))
    
45.      (setq
    
46.        m.back (cond ((= 0 (strlen m.back)) (strcat m.back "000"))
    
47.                           ((= 1 (strlen m.back)) (strcat m.back "00"))
    
48.         ((= 2 (strlen m.back)) (strcat m.back "0"))
    
49.         ((= 3 (strlen m.back)) m.back)
    
50.         )
    
51.      )
    
52.      ;;里程桩内容
    
53.      (setq str (strcat "K"
    
54.            (itoa K)
    
55.            "+"
    
56.            (substr mstr (+ 2 ptnum) 3)
    
57.            "."
    
58.            m.back
    
59. 
    
60.          )
    
61.      )
    
62.      ;;找出X或者Y坐标值小的点
    
63.      (setq plist (if (= (car val) (car p))
    
64.        (progn
    
65.          (vl-sort (list val p)
    
66.             (function (lambda (e1 e2)
    
67.             (< (cadr e1) (cadr e2))
    
68.                 )
    
69.             )
    
70.          )
    
71.        )
    
72.        ;;如果X值相等，Y值小的在前面
    
73.        (progn
    
74.          (vl-sort
    
75.            (list val p)
    
76.            (function (lambda (e1 e2)
    
77.            (< (car e1) (car e2))
    
78.                )
    
79.            )
    
80.          )
    
81.        )
    
82.        ;;否则X值小的在前面
    
83.            )
    
84.      )
    
85.      (setq ang (angle (car plist) (cadr plist)))
    
86.      (setq el (subst (cons 1 str) (assoc 1 el) el))
    
87.      ;;坐标
    
88.      (setq el (subst (cons 10 val) (assoc 10 el) el))
    
89.      ;;角度
    
90.      (setq el (subst (cons 50 ang) (assoc 50 el) el))
    
91.      ;;高度
    
92.      (setq el (subst (cons 40 (* 0.05 (distance val p)))
    
93.          (assoc 40 el)
    
94.          el
    
95.         )
    
96.      )
    
97.      ;;更新图元名列表
    
98.      (entmod el)
    
99.     )
    
100.     ;;鼠标左键、右键退出画线
     
101.     ((or (= 25 mod) (= 3 mod))
     
102.      (entmake (list '(0 . "LINE")
     
103.         (cons 10 p)
     
104.         (cons 11 val)
     
105.         (cons 8 "桩号标注")
     
106.         (cons 62 1)
     
107.         )
     
108.      )
     
109.      (setq loop nil)
     
110.     )
     
111.     )
     
112.   )
     
113.     (setvar "DIMZIN" dim)
     
114.   (setvar "UNITMODE" unt)
     
115.   (setvar "osmode" os)
     
116. ;;;  (redraw)
     
117. )
     

(defun c:zh (/ os e obj  loop el  code mod val p l K m mstr ptmun  m.back<br />          plist)<br />   (setq dim (getvar "DIMZIN"))<br />   (setq unt (getvar "UNITMODE"))<br />   (setvar "DIMZIN" 0)<br />   (setvar "UNITMODE" 0)<br />   (setq os (getvar "osmode"))<br />   (setq e (car (entsel "\n 请选择需要标注的多段线=>> ")))<br />   (prompt "\n <<****欢迎使用逐桩标注程序****>>")<br />   (setq obj (vlax-ename->vla-object e))<br />   (entmake (list '(0 . "TEXT")<br />      (cons 1 "0")<br />      '(10 0 0 0)<br />      (cons 40 1)<br />      (cons 62 3)<br />      (cons 8 "桩号标注")<br />      )<br />   )<br />   (setq el (entget (entlast)))<br /> ;;;  (setq p (getpoint "\n 请选择需要标注的点位 "))<br />   (setq loop T)<br />   (while loop<br />     (setq code (grread T 4 1)<br />     mod  (car code)<br />     val  (cadr code)<br />     )<br />     (cond ((= 5 mod)<br />      ;;获取离曲线最近的点<br />      (setq p (vlax-curve-getClosestPointTo<br />          obj<br />          val<br />        )<br />      )<br />      (redraw)<br />      (grdraw val p 3)<br />      ;;指定点到起点的距离<br />      (setq l (vlax-curve-getDistAtPoint obj p)<br />      K (fix (* 0.001 l))<br />      m (- (* 0.001 l) K)<br />      )<br />      (setq mstr (rtos m 2 6))<br />      (setq ptnum (vl-string-search "." mstr))<br />      (setq m.back (substr mstr (+ 5 ptnum) 3))<br />      (setq<br />        m.back (cond ((= 0 (strlen m.back)) (strcat m.back "000"))<br />                           ((= 1 (strlen m.back)) (strcat m.back "00"))<br />         ((= 2 (strlen m.back)) (strcat m.back "0"))<br />         ((= 3 (strlen m.back)) m.back)<br />         )<br />      )<br />      ;;里程桩内容<br />      (setq str (strcat "K"<br />            (itoa K)<br />            "+"<br />            (substr mstr (+ 2 ptnum) 3)<br />            "."<br />            m.back<br /> <br />          )<br />      )<br />      ;;找出X或者Y坐标值小的点<br />      (setq plist (if (= (car val) (car p))<br />        (progn<br />          (vl-sort (list val p)<br />             (function (lambda (e1 e2)<br />             (< (cadr e1) (cadr e2))<br />                 )<br />             )<br />          )<br />        )<br />        ;;如果X值相等，Y值小的在前面<br />        (progn<br />          (vl-sort<br />            (list val p)<br />            (function (lambda (e1 e2)<br />            (< (car e1) (car e2))<br />                )<br />            )<br />          )<br />        )<br />        ;;否则X值小的在前面<br />            )<br />      )<br />      (setq ang (angle (car plist) (cadr plist)))<br />      (setq el (subst (cons 1 str) (assoc 1 el) el))<br />      ;;坐标<br />      (setq el (subst (cons 10 val) (assoc 10 el) el))<br />      ;;角度<br />      (setq el (subst (cons 50 ang) (assoc 50 el) el))<br />      ;;高度<br />      (setq el (subst (cons 40 (* 0.05 (distance val p)))<br />          (assoc 40 el)<br />          el<br />         )<br />      )<br />      ;;更新图元名列表<br />      (entmod el)<br />     )<br />     ;;鼠标左键、右键退出画线<br />     ((or (= 25 mod) (= 3 mod))<br />      (entmake (list '(0 . "LINE")<br />         (cons 10 p)<br />         (cons 11 val)<br />         (cons 8 "桩号标注")<br />         (cons 62 1)<br />         )<br />      )<br />      (setq loop nil)<br />     )<br />     )<br />   )<br />     (setvar "DIMZIN" dim)<br />   (setvar "UNITMODE" unt)<br />   (setvar "osmode" os)<br /> ;;;  (redraw)<br /> )<br />

USER2128

给一个测试grread返回值的程序，估计是因按“回车键”时的同时，产生了附加码引起的
;;;============================================
;;; 测试 (grread t 4 2) 返回值，按键盘上的“空格”键结束，屏蔽了鼠标移动过程中的显示值
(while(/=(cadr(setq tmp(grread t 4 2)))32)(if(/=(car tmp)5)(progn(princ"\n")(princ tmp))))
;;;============================================

newbuser

找到原因了，问题出在那个里程桩号生成的那个函数上。
在程序开始时保存dimzin和unitmode变量并将该两项变量设置为0，程序运行完后再回复该两项系统变量即可。代码已更新，在楼顶。

zzyong00

帮楼主顶贴

Atsai

楼主这个赞，动态的不错哦！

czb203

赞，不错啊  支持啊··～～～

spp_wall

支持下  能指定标注桩号就更好！！

mycad

顶！！！！！！！！！！！

chcumt

帮顶一个   

zwf100

这个程序不错，很实用