Grread应用的动态弯道标注

xgr

前不久看到有人需要动态弯道标注的程序，正好自己也有这样的想法，就写了一个。

2. ;;  通用grread定义
   
3. (defun ZML-GRREAD (LST / test tmp mode val tmp2)
   
4.   (setq test t)
   
5.   (while test
   
6.     (setq tmp  (grread 2)
   
7.     mode (car tmp)
   
8.     val  (cadr tmp)
   
9.     )
   
10.     (cond ((= mode 2)
    
11.      (if (and (setq tmp2 (assoc mode lst)) (setq tmp2 (cdr tmp2)) (setq tmp2 (assoc val tmp2)))
    
12.        (eval (cons 'progn (cdr tmp2)))
    
13.        ()
    
14.      )
    
15.     )
    
16.     ((setq tmp2 (assoc mode lst)) (eval (cons 'progn (cdr tmp2))))
    
17.     (t (princ tmp))
    
18.     )
    
19.   )
    
20. )
    

;;  通用grread定义<br /> (defun ZML-GRREAD (LST / test tmp mode val tmp2)<br />   (setq test t)<br />   (while test<br />     (setq tmp  (grread 2)<br />     mode (car tmp)<br />     val  (cadr tmp)<br />     )<br />     (cond ((= mode 2)<br />      (if (and (setq tmp2 (assoc mode lst)) (setq tmp2 (cdr tmp2)) (setq tmp2 (assoc val tmp2)))<br />        (eval (cons 'progn (cdr tmp2)))<br />        ()<br />      )<br />     )<br />     ((setq tmp2 (assoc mode lst)) (eval (cons 'progn (cdr tmp2))))<br />     (t (princ tmp))<br />     )<br />   )<br /> )<br />

2. ;;;动态弯道标注
   
3. (defun c:wdbz ()
   
4.    (prompt "\n 弯道标注程序加载成功,只支持圆弧线！")
   
5.   (setq oldosmode (getvar "osmode"))
   
6.   (setq  l   (getvar "ltscale")
   
7.   scale   1.0
   
8.   textsize (* l 3.0)
   
9.   )
   
10.   (vl-load-com)
    
11.   (if (and (setq en1 (entsel "\n 请选取轨道中心线弧线："))
    
12.      (setq arcobj (vlax-ename->vla-object (car en1)))
    
13.      ;;得到起点坐标
    
14.      (setq Startpt (vla-get-StartPoint arcobj))
    
15.      (setq Startpt (vlax-variant-value Startpt))
    
16.      (setq StartPoint (vlax-safearray->list Startpt))
    
17.      ;;得到终点坐标
    
18.      (setq Endpt (vla-get-EndPoint arcobj))
    
19.      (setq Endpt (vlax-variant-value Endpt))
    
20.      (setq EndPoint (vlax-safearray->list Endpt))
    
21.      ;;得到圆心坐标
    
22.      (setq Centerpt (vla-get-Center arcobj))
    
23.      (setq Centerpt (vlax-variant-value Centerpt))
    
24.      (setq CenterPoint (vlax-safearray->list Centerpt))
    
25.      ;;得到弧的夹角
    
26.      (setq totalangle (vla-get-totalangle arcobj))
    
27.      ;;得到d-f-m
    
28.      (setq ang_d (fix (/ (* totalangle 180) pi))
    
29.      ang_f (fix (* (- (/ (* totalangle 180) pi) ang_d) 60))
    
30.      ang_m (fix (* (- (/ (* totalangle 180) pi) ang_d (/ ang_f 60.0)) 3600))
    
31.      )
    
32.      ;;得到转角数
    
33.      (setq ang (strcat "θ="
    
34.            (itoa ang_d)
    
35.            "°"
    
36.            (if (> ang_f 10)
    
37.              (itoa ang_f)
    
38.              (strcat "0" (itoa ang_f))
    
39.            )
    
40.            "′"
    
41.            (if (> ang_m 10)
    
42.              (itoa ang_m)
    
43.              (strcat "0" (itoa ang_m))
    
44.            )
    
45.            "″"
    
46.          )
    
47.      )
    
48.      ;;获取半径
    
49.      (setq radius (fix (* (vla-get-radius arcobj) 1000)))
    
50.      ;;取弧长
    
51.      (setq ArcLength (fix (* (vla-get-ArcLength arcobj) 1000)))
    
52.      ;;-----------------------------------------      
    
53.      ;;绘制引线                                     θ
    
54.      (setq pt1 (getpoint "\n选择标注点: "))
    
55.      ;; 这个范例在模型空间中建立具有一个关联式注释的一条引线，
    
56.      ;; 接着显示新的引线的注释对象。
    
57.      (setq AcadObject   (vlax-get-acad-object)
    
58.      AcadDocument (vla-get-ActiveDocument Acadobject)
    
59.      mSpace        (vla-get-ModelSpace Acaddocument)
    
60.      )
    
61.      ;; 定义新的 MText 对象
    
62.      (setq textString (strcat ang "\n" (strcat "R=" (itoa radius)) "\n" (strcat "L=" (itoa ArcLength))))
    
63.      (setq insertionPnt (vlax-make-safearray vlax-vbDouble '(0 . 2)))
    
64.      (vlax-safearray-fill insertionPnt pt1)
    
65.      (setq width (distance (car (textbox (list (cons 1 ang)))) (cadr (textbox (list (cons 1 ang))))))
    
66.      ;; 在模型空间中建立MText 对象
    
67.      (setq MTextObj (vla-AddMText mSpace insertionPnt width textString))
    
68.      ;;填满wenzi
    
69.      (setq wenzi (vlax-make-safearray vlax-vbString '(1 . 9)))
    
70.      (vlax-safearray-fill
    
71.        wenzi
    
72.        '("TopLeft" "TopCenter" "TopRight"  "MiddleLeft" "MiddleCenter" "MiddleRight" "BottomLeft" "BottomCenter" "BottomRight")
    
73.      )
    
74.      ;; 引线数据
    
75.      (setq pnts (vlax-make-safearray vlax-vbDouble '(0 . 5)))
    
76.      (vlax-safearray-fill pnts (append pt1 (polar pt1 0 1)))
    
77.      ;;是否显示箭头
    
78.      (setq leaderType acLineWithArrow)
    
79.      ;;设置初始箭头为"实心闭合"
    
80.      (setq ArrowheadType 0)
    
81.      ;;创建箭头类型列表
    
82.      (setq ArrowheadTypeList (vlax-make-safearray vlax-vbstring '(1 . 20)))
    
83.      (vlax-safearray-fill
    
84.        ArrowheadTypeList
    
85.        '("实心闭合" "空心闭合" "闭合" "点" "建筑标记" "倾斜" "打开" "指示原点" "指示原点2" "直角"  "30度角" "小点"  "空心点" "空心小点" "方框" "实心方框" "基准三角形" "实心基准三角形" "积分" "无")
    
86.      )
    
87.      ;; 在模型中建立Leader 对象，接着将MText对象设成
    
88.      ;; Leader注释，使新的MText对象和新的Leader对象建立关联
    
89.      (setq annotationObject MTextObj)
    
90.      (setq leaderObj (vla-AddLeader mSpace pnts annotationObject leaderType))
    
91.      (princ "\n")
    
92.       )
    
93.     (progn (setq LST (list '(5
    
94.            (grdraw CenterPoint StartPoint 1)
    
95.            (grdraw CenterPoint EndPoint 1)
    
96.            (setq pt val)
    
97.            ;;更新文字插入点
    
98.            (vla-put-InsertionPoint MTextObj (vlax-3d-point pt))
    
99.            ;;更新文字插入点
    
100.            ;;设置文字的对齐点
     
101.            (vla-put-AttachmentPoint MTextObj acAttachmentPointBottomLeft)
     
102.            ;;修改文字颜色
     
103.            (vla-put-Color MTextObj 3)
     
104.            (vla-put-Layer MTextObj "zj")
     
105.            (vla-put-Width MTextObj width)
     
106.            (if
     
107.             (<= (car pt) (car pt1))
     
108.             ;;如果鼠标移动点的x坐标值小于等于最近点的X坐标值
     
109.             (vla-put-AttachmentPoint MTextObj 9)
     
110.             ;;更改文字的贴附点为9（右下角）
     
111.             (vla-put-AttachmentPoint MTextObj 7)
     
112.             ;;更改文字的贴附点为7（左下角）
     
113.            )
     
114.            ;;end_if
     
115.            (setq pnts1 (vlax-make-safearray vlax-vbDouble '(0 . 5)))
     
116.            (vlax-safearray-fill pnts1 (append pt1 (polar pt 0 1)))
     
117.            (vla-put-Coordinates leaderObj pnts1)
     
118.            ;;更新引线插入点
     
119.            ;;设置文字标注在上方
     
120.            (vla-put-VerticalTextPosition leaderObj acAbove)
     
121.            ;;设置文字与标注线的垂直距离
     
122.            (vla-put-TextGap leaderObj (* l 1))
     
123.            ;;设置标注线的图层
     
124.            (vla-put-layer leaderObj "zj")
     
125.            ;;设置标注线的颜色
     
126.            (vla-put-DimensionLineColor leaderObj 1)
     
127.            ;;设置初始箭头大小
     
128.            (vla-put-ArrowheadSize leaderObj scale)
     
129.            (princ "\n按加减号改变箭头大小<+/->,按 </> 键改变文字高度,按Tab键改变箭头样式:")
     
130.           )
     
131.          '(2
     
132.            ;;按TAB键
     
133.            (9
     
134.             (setq ArrowheadType (+ ArrowheadType 1))
     
135.             (if
     
136.              (> ArrowheadType 19)
     
137.              (setq ArrowheadType 0)
     
138.             )
     
139.             ;;修改箭头大小
     
140.             (vla-put-ArrowheadType leaderObj ArrowheadType)
     
141.             (princ
     
142.              (strcat
     
143.         "\n箭头变换啦***"
     
144.         " 当前箭头样式为->"
     
145.         (vlax-safearray-get-element ArrowheadTypeList (+ ArrowheadType 1))
     
146.              )
     
147.             )
     
148.            )
     
149.            (43
     
150.             (setq scale (+ scale 0.1))
     
151.             ;;修改箭头大小
     
152.             (vla-put-ArrowheadSize leaderObj scale)
     
153.             (princ (strcat "\n箭头增大啦***" " 当前比例=" (rtos scale 2 1)))
     
154.            )
     
155.            (45
     
156.             (setq scale (- scale 0.1))
     
157.             ;;修改箭头大小
     
158.             (if
     
159.              (> scale 0.18)
     
160.              (progn
     
161.         (vla-put-ArrowheadSize leaderObj scale)
     
162.         (princ (strcat "\n箭头减小啦***" " 当前比例=" (rtos scale 2 1)))
     
163.              )
     
164.              (princ "\n箭头已经是最小了！")
     
165.             )
     
166.            )
     
167.            ;;修改文字高度
     
168.            (44
     
169.             (setq width (* width (/ (+ textsize 0.1) textsize)))
     
170.             (setq textsize (+ textsize 0.1))
     
171.             (vla-put-Height MTextObj textsize)
     
172.             (princ (strcat "\n文字高度增大啦***" " 当前高度=" (rtos textsize 2 1)))
     
173.            )
     
174.            (46
     
175.             (setq width (* width (/ (- textsize 0.1) textsize)))
     
176.             (setq textsize (- textsize 0.1))
     
177.             (vla-put-Height MTextObj textsize)
     
178.             (princ (strcat "\n文字高度减小啦***" " 当前高度=" (rtos textsize 2 1)))
     
179.            )
     
180.           )
     
181.          ;;左击
     
182.          '
     
183.           (3 (setq pt val)
     
184.              (initget 1 " y n Y N  ")
     
185.              (setq xunwen (getkword "\n是否绘制半径[Y/N或回车退出]:"))
     
186.              (if (or (= xunwen "y") (= xunwen "Y") (= xunwen " "))
     
187.          (progn (command "line" CenterPoint StartPoint "") (command "line" CenterPoint EndPoint ""))
     
188.              )
     
189.              (redraw)
     
190.              (setq TEST NIL)
     
191.              (setvar "osmode" oldosmode)
     
192.           )
     
193.              '(25 (redraw) (setq TEST NIL))
     
194.              '(11 (redraw) (setq TEST NIL))
     
195.           )
     
196.      )
     
197.      (ZML-GRREAD lst)
     
198.     )
     
199.   )
     
200.   (princ)
     
201. )
     

;;;动态弯道标注<br /> (defun c:wdbz ()<br />    (prompt "\n 弯道标注程序加载成功,只支持圆弧线！")<br />   (setq oldosmode (getvar "osmode"))<br />   (setq  l   (getvar "ltscale")<br />   scale   1.0<br />   textsize (* l 3.0)<br />   )<br />   (vl-load-com)<br />   (if (and (setq en1 (entsel "\n 请选取轨道中心线弧线："))<br />      (setq arcobj (vlax-ename->vla-object (car en1)))<br />      ;;得到起点坐标<br />      (setq Startpt (vla-get-StartPoint arcobj))<br />      (setq Startpt (vlax-variant-value Startpt))<br />      (setq StartPoint (vlax-safearray->list Startpt))<br />      ;;得到终点坐标<br />      (setq Endpt (vla-get-EndPoint arcobj))<br />      (setq Endpt (vlax-variant-value Endpt))<br />      (setq EndPoint (vlax-safearray->list Endpt))<br />      ;;得到圆心坐标<br />      (setq Centerpt (vla-get-Center arcobj))<br />      (setq Centerpt (vlax-variant-value Centerpt))<br />      (setq CenterPoint (vlax-safearray->list Centerpt))<br />      ;;得到弧的夹角<br />      (setq totalangle (vla-get-totalangle arcobj))<br />      ;;得到d-f-m<br />      (setq ang_d (fix (/ (* totalangle 180) pi))<br />      ang_f (fix (* (- (/ (* totalangle 180) pi) ang_d) 60))<br />      ang_m (fix (* (- (/ (* totalangle 180) pi) ang_d (/ ang_f 60.0)) 3600))<br />      )<br />      ;;得到转角数<br />      (setq ang (strcat "θ="<br />            (itoa ang_d)<br />            "°"<br />            (if (> ang_f 10)<br />              (itoa ang_f)<br />              (strcat "0" (itoa ang_f))<br />            )<br />            "′"<br />            (if (> ang_m 10)<br />              (itoa ang_m)<br />              (strcat "0" (itoa ang_m))<br />            )<br />            "″"<br />          )<br />      )<br />      ;;获取半径<br />      (setq radius (fix (* (vla-get-radius arcobj) 1000)))<br />      ;;取弧长<br />      (setq ArcLength (fix (* (vla-get-ArcLength arcobj) 1000)))<br />      ;;-----------------------------------------      <br />      ;;绘制引线                                     θ<br />      (setq pt1 (getpoint "\n选择标注点: "))<br />      ;; 这个范例在模型空间中建立具有一个关联式注释的一条引线，<br />      ;; 接着显示新的引线的注释对象。<br />      (setq AcadObject   (vlax-get-acad-object)<br />      AcadDocument (vla-get-ActiveDocument Acadobject)<br />      mSpace        (vla-get-ModelSpace Acaddocument)<br />      )<br />      ;; 定义新的 MText 对象<br />      (setq textString (strcat ang "\n" (strcat "R=" (itoa radius)) "\n" (strcat "L=" (itoa ArcLength))))<br />      (setq insertionPnt (vlax-make-safearray vlax-vbDouble '(0 . 2)))<br />      (vlax-safearray-fill insertionPnt pt1)<br />      (setq width (distance (car (textbox (list (cons 1 ang)))) (cadr (textbox (list (cons 1 ang))))))<br />      ;; 在模型空间中建立MText 对象<br />      (setq MTextObj (vla-AddMText mSpace insertionPnt width textString))<br />      ;;填满wenzi<br />      (setq wenzi (vlax-make-safearray vlax-vbString '(1 . 9)))<br />      (vlax-safearray-fill<br />        wenzi<br />        '("TopLeft" "TopCenter" "TopRight"  "MiddleLeft" "MiddleCenter" "MiddleRight" "BottomLeft" "BottomCenter" "BottomRight")<br />      )<br />      ;; 引线数据<br />      (setq pnts (vlax-make-safearray vlax-vbDouble '(0 . 5)))<br />      (vlax-safearray-fill pnts (append pt1 (polar pt1 0 1)))<br />      ;;是否显示箭头<br />      (setq leaderType acLineWithArrow)<br />      ;;设置初始箭头为"实心闭合"<br />      (setq ArrowheadType 0)<br />      ;;创建箭头类型列表<br />      (setq ArrowheadTypeList (vlax-make-safearray vlax-vbstring '(1 . 20)))<br />      (vlax-safearray-fill<br />        ArrowheadTypeList<br />        '("实心闭合" "空心闭合" "闭合" "点" "建筑标记" "倾斜" "打开" "指示原点" "指示原点2" "直角"  "30度角" "小点"  "空心点" "空心小点" "方框" "实心方框" "基准三角形" "实心基准三角形" "积分" "无")<br />      )<br />      ;; 在模型中建立Leader 对象，接着将MText对象设成<br />      ;; Leader注释，使新的MText对象和新的Leader对象建立关联<br />      (setq annotationObject MTextObj)<br />      (setq leaderObj (vla-AddLeader mSpace pnts annotationObject leaderType))<br />      (princ "\n")<br />       )<br />     (progn (setq LST (list '(5<br />            (grdraw CenterPoint StartPoint 1)<br />            (grdraw CenterPoint EndPoint 1)<br />            (setq pt val)<br />            ;;更新文字插入点<br />            (vla-put-InsertionPoint MTextObj (vlax-3d-point pt))<br />            ;;更新文字插入点<br />            ;;设置文字的对齐点<br />            (vla-put-AttachmentPoint MTextObj acAttachmentPointBottomLeft)<br />            ;;修改文字颜色<br />            (vla-put-Color MTextObj 3)<br />            (vla-put-Layer MTextObj "zj")<br />            (vla-put-Width MTextObj width)<br />            (if<br />             (<= (car pt) (car pt1))<br />             ;;如果鼠标移动点的x坐标值小于等于最近点的X坐标值<br />             (vla-put-AttachmentPoint MTextObj 9)<br />             ;;更改文字的贴附点为9（右下角）<br />             (vla-put-AttachmentPoint MTextObj 7)<br />             ;;更改文字的贴附点为7（左下角）<br />            )<br />            ;;end_if<br />            (setq pnts1 (vlax-make-safearray vlax-vbDouble '(0 . 5)))<br />            (vlax-safearray-fill pnts1 (append pt1 (polar pt 0 1)))<br />            (vla-put-Coordinates leaderObj pnts1)<br />            ;;更新引线插入点<br />            ;;设置文字标注在上方<br />            (vla-put-VerticalTextPosition leaderObj acAbove)<br />            ;;设置文字与标注线的垂直距离<br />            (vla-put-TextGap leaderObj (* l 1))<br />            ;;设置标注线的图层<br />            (vla-put-layer leaderObj "zj")<br />            ;;设置标注线的颜色<br />            (vla-put-DimensionLineColor leaderObj 1)<br />            ;;设置初始箭头大小<br />            (vla-put-ArrowheadSize leaderObj scale)<br />            (princ "\n按加减号改变箭头大小<+/->,按 </> 键改变文字高度,按Tab键改变箭头样式:")<br />           )<br />          '(2<br />            ;;按TAB键<br />            (9<br />             (setq ArrowheadType (+ ArrowheadType 1))<br />             (if<br />              (> ArrowheadType 19)<br />              (setq ArrowheadType 0)<br />             )<br />             ;;修改箭头大小<br />             (vla-put-ArrowheadType leaderObj ArrowheadType)<br />             (princ<br />              (strcat<br />         "\n箭头变换啦***"<br />         " 当前箭头样式为->"<br />         (vlax-safearray-get-element ArrowheadTypeList (+ ArrowheadType 1))<br />              )<br />             )<br />            )<br />            (43<br />             (setq scale (+ scale 0.1))<br />             ;;修改箭头大小<br />             (vla-put-ArrowheadSize leaderObj scale)<br />             (princ (strcat "\n箭头增大啦***" " 当前比例=" (rtos scale 2 1)))<br />            )<br />            (45<br />             (setq scale (- scale 0.1))<br />             ;;修改箭头大小<br />             (if<br />              (> scale 0.18)<br />              (progn<br />         (vla-put-ArrowheadSize leaderObj scale)<br />         (princ (strcat "\n箭头减小啦***" " 当前比例=" (rtos scale 2 1)))<br />              )<br />              (princ "\n箭头已经是最小了！")<br />             )<br />            )<br />            ;;修改文字高度<br />            (44<br />             (setq width (* width (/ (+ textsize 0.1) textsize)))<br />             (setq textsize (+ textsize 0.1))<br />             (vla-put-Height MTextObj textsize)<br />             (princ (strcat "\n文字高度增大啦***" " 当前高度=" (rtos textsize 2 1)))<br />            )<br />            (46<br />             (setq width (* width (/ (- textsize 0.1) textsize)))<br />             (setq textsize (- textsize 0.1))<br />             (vla-put-Height MTextObj textsize)<br />             (princ (strcat "\n文字高度减小啦***" " 当前高度=" (rtos textsize 2 1)))<br />            )<br />           )<br />          ;;左击<br />          '<br />           (3 (setq pt val)<br />              (initget 1 " y n Y N  ")<br />              (setq xunwen (getkword "\n是否绘制半径[Y/N或回车退出]:"))<br />              (if (or (= xunwen "y") (= xunwen "Y") (= xunwen " "))<br />          (progn (command "line" CenterPoint StartPoint "") (command "line" CenterPoint EndPoint ""))<br />              )<br />              (redraw)<br />              (setq TEST NIL)<br />              (setvar "osmode" oldosmode)<br />           )<br />              '(25 (redraw) (setq TEST NIL))<br />              '(11 (redraw) (setq TEST NIL))<br />           )<br />      )<br />      (ZML-GRREAD lst)<br />     )<br />   )<br />   (princ)<br /> )<br />

(ZML-GRREAD lst)为网上搜集。

cnks

有源码，支持一下

露草

现在还只会LISP类函数

vlisp2012

win7 cad2011显示 ：错误: Automation 错误。 未找到主键

zml84

ZML-GRREAD 连作者信息都被去掉了，太不厚道了

hao3ren

zml84 发表于 2012-9-24 14:04
ZML-GRREAD 连作者信息都被去掉了，太不厚道了

呵呵，这种事情太多了，第一个转载没有作者信息，后面再转载的就更木有了，不过你的函数有前缀ZML大家一看就知道了

xiaoyuzj-503

学习学习  先收藏了

yoyoho

感谢xgr 分享学习!