修改直线、角度显示精度（保留2位小数）

lff763

求助：怎样修改直线、角度显示精度（保留2位小数）

lff763

2. ;;
   
3. ;;功能：动态查询信息
   
4. ;;文件：info.lsp
   
5. ;;命令：info或'info透明调用
   
6. ;;使用：鼠标移动查询信息，鼠标左键编辑，鼠标右键退出
   
7. ;;作者：YAD
   
8. ;;
   
9. 
   
10. (defun c:info (/ myerr dxf del_ss tran_ang tran_zb add_solid add_text dis_info
    
11.                  acaddoc olderr oldvar ss loop gr pt ent oldent)
    
12.   (defun myerr (msg)
    
13.     (del_ss ss)
    
14.     (setq *error* olderr)
    
15.   )
    
16.   (defun dxf (ent n)
    
17.     (if        (= (type ent) 'ename)
    
18.       (setq ent (entget ent))
    
19.     )
    
20.     (cdr (assoc n ent))
    
21.   )
    
22.   (defun del_ss (ss / n)
    
23.     (setq n -1)
    
24.     (repeat (sslength ss)
    
25.       (entdel (ssname ss (setq n (1+ n))))
    
26.     )
    
27.     (if oldent (redraw oldent 4))
    
28.   )
    
29.   (defun tran_ang (ang)
    
30.     (strcat (rtos (* ang (/ 180 pi)) 2 (getvar "auprec")) "度")
    
31.   )
    
32.   (defun tran_zb (nm / zb)
    
33.     (if (= (type nm) 'int) (setq zb (dxf ent nm)) (setq zb nm))
    
34.     (strcat (rtos (car zb) 2 lup) "," (rtos (cadr zb) 2 lup) (if (caddr zb) (strcat "," (rtos (caddr zb) 2 lup)) ""))
    
35.   )
    
36.   (defun add_solid (p1 p2 p3 p4)
    
37.     (entmakex (list (cons 0 "SOLID") (cons 100 "AcDbEntity") (cons 62 1) (cons 100 "AcDbTrace")
    
38.                     (cons 10 p1)(cons 11 p2) (cons 12 p3) (cons 13 p4) (cons 210 (trans (getvar "viewdir") 1 0))
    
39.     ))
    
40.   )
    
41.   (defun add_text (pt h txt)
    
42.     (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 62 2) (cons 100 "AcDbText")
    
43.                     (cons 10 pt) (cons 40 h) (cons 1 txt) (cons 50 0.0) (cons 7 "info") (cons 72 0) (cons 73 0)
    
44.                     (cons 210 (trans (getvar "viewdir") 1 0))
    
45.     ))
    
46.   )
    
47.   (defun dis_info (ent / obj laynm name lup lst h high width ang n)
    
48.     (setq obj (vlax-ename->vla-object ent)
    
49.           laynm        (strcat "图层:" (dxf ent 8))
    
50.           name        (dxf ent 0)
    
51.           lup (getvar "luprec")
    
52.     )
    
53.     (cond                          ;;*****以下内容可以根据个人需要按格式调整*****
    
54.       ((= name "3DFACE")
    
55.         (setq lst (list "【三维面】"))
    
56.       )
    
57.       ((= name "3DSOLID")
    
58.         (setq lst (list "【三维实体】"
    
59.                         (strcat "质心:" (tran_zb (vlax-safearray->list (vlax-variant-value (vla-get-Centroid obj)))))
    
60.                         (strcat "惯性矩:" (tran_zb (vlax-safearray->list (vlax-variant-value (vla-get-MomentOfInertia obj)))))
    
61.                         (strcat "旋转半径:" (tran_zb (vlax-safearray->list (vlax-variant-value (vla-get-RadiiOfGyration obj)))))
    
62.         ))
    
63.       )
    
64.       ((= name "ACAD_PROXY_ENTITY")
    
65.         (setq lst (list "【代理】"))
    
66.       )
    
67.       ((= name "ARC")
    
68.         (setq lst (list "【圆弧】"
    
69.                         (strcat "圆心坐标:" (tran_zb 10))
    
70.                         (strcat "半径:"   (rtos (vla-get-radius obj) 2 lup))
    
71.                         (strcat "圆心角:" (tran_ang (vla-get-TotalAngle obj)))
    
72.                         (strcat "起始角:" (tran_ang (vla-get-StartAngle obj)))
    
73.                         (strcat "终止角:" (tran_ang (vla-get-EndAngle obj)))
    
74.                         (strcat "总弧长:" (rtos (vla-get-ArcLength obj) 2 lup))
    
75.                         (strcat "面积:"   (rtos (vla-get-Area obj) 2 lup))
    
76.         ))
    
77.       )
    
78.       ((= name "ATTDEF")
    
79.         (setq lst (list "【属性定义】"
    
80.                         (strcat "位置坐标:" (tran_zb 10))
    
81.                         (strcat "标签:" (vla-get-TagString obj))
    
82.                         (strcat "提示:" (vla-get-PromptString obj))
    
83.                         (strcat "缺省值:" (vla-get-TextString obj))
    
84.                         (strcat "高度:" (rtos (vla-get-Height obj) 2 lup))
    
85.                         (strcat "角度:" (tran_ang (vla-get-Rotation obj)))
    
86.                         (strcat "文字样式:" (vla-get-StyleName obj))
    
87.         ))
    
88.       )
    
89.       ((= name "ATTRIB")
    
90.         (setq lst (list "【属性】"
    
91.                         (strcat "位置坐标:" (tran_zb 10))
    
92.                         (strcat "标签:" (vla-get-TagString obj))
    
93.                         (strcat "缺省值:" (vla-get-TextString obj))
    
94.                         (strcat "高度:" (rtos (vla-get-Height obj) 2 lup))
    
95.                         (strcat "角度:" (tran_ang (vla-get-Rotation obj)))
    
96.                         (strcat "文字样式:" (vla-get-StyleName obj))
    
97.         ))
    
98.       )
    
99.       ((= name "CIRCLE")
    
100.         (setq lst (list "【圆】"
     
101.                         (strcat "圆心坐标:" (tran_zb 10))
     
102.                         (strcat "半径:" (rtos (vla-get-radius obj) 2 lup))
     
103.                         (strcat "周长:" (rtos (vla-get-Circumference obj) 2 lup))
     
104.                         (strcat "面积:" (rtos (vla-get-Area obj) 2 lup))
     
105.         ))
     
106.       )
     
107.       ((= name "DIMENSION")
     
108.         (setq lst (list "【尺寸标注】"
     
109.                         (strcat "标注样式:" (vla-get-StyleName obj))
     
110.                         (strcat "文字样式:" (vla-get-TextStyle obj))
     
111.                         (strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 lup))
     
112.                         (strcat        "替带文字:" (if (= (dxf ent 1) "") "无" (dxf ent 1)))
     
113.         ))
     
114.       )
     
115.       ((= name "ELLIPSE")
     
116.         (setq lst (list        "【椭圆】"
     
117.                         (strcat "圆心坐标:" (tran_zb 10))
     
118.                         (strcat "长轴半径:" (rtos (vla-get-MajorRadius obj) 2 lup))
     
119.                         (strcat "短轴半径:" (rtos (vla-get-MinorRadius obj) 2 lup))
     
120.                         (strcat        "起始角:" (tran_ang (vla-get-StartAngle obj)))
     
121.                         (strcat        "终止角:" (tran_ang (vla-get-EndAngle obj)))
     
122.                         (strcat "周长:" (rtos (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj)) 2 lup))
     
123.                         (strcat        "面积:"        (rtos (vla-get-Area obj) 2 lup))
     
124.         ))
     
125.       )
     
126.       ((= name "HATCH")
     
127.         (setq lst (list        "【图案填充】"
     
128.                         (strcat "图案名称:" (vla-get-PatternName obj))
     
129.                         (strcat        "角度:"        (tran_ang (vla-get-PatternAngle obj)))
     
130.                         (strcat "比例:" (rtos (vla-get-PatternScale obj) 2 lup))
     
131.                         (strcat "关联:" (if (= (vla-get-AssociativeHatch obj) :vlax-false) "关闭" "打开"))
     
132.                         (strcat "填充样式:" (nth (vla-get-HatchStyle obj) '("普通" "外部" "忽略")))
     
133.         ))
     
134.       )
     
135.       ((= name "IMAGE")
     
136.         (setq lst (list "【图像】"
     
137.                         (strcat "插入坐标:" (tran_zb 10))
     
138.                         (strcat "图像大小:" (rtos (car (dxf ent 13)) 2 lup) "X" (rtos (cadr (dxf ent 13)) 2 lup))
     
139.         ))
     
140.       )
     
141.       ((= name "INSERT")
     
142.         (setq lst (list "【图块】"
     
143.                         (strcat "插入坐标:" (tran_zb 10))
     
144.                         (strcat "名称:" (vla-get-Name obj))
     
145.                         (strcat "X比例:" (rtos (vla-get-XScaleFactor obj) 2 lup))
     
146.                         (strcat "Y比例:" (rtos (vla-get-YScaleFactor obj) 2 lup))
     
147.                         (strcat "Z比例:" (rtos (vla-get-ZScaleFactor obj) 2 lup))
     
148.                         (strcat "角度:" (tran_ang (vla-get-Rotation obj)))
     
149.         ))
     
150.       )
     
151.       ((= name "LEADER")
     
152.         (setq lst (list "【引线】"
     
153.                         (strcat "标注样式:" (vla-get-StyleName obj))
     
154.                         (strcat "引线类型:" (nth (vla-get-Type obj) '("无箭头直线" "无箭头曲线" "箭头直线" "箭头曲线")))
     
155.                         (strcat "文字偏移:" (rtos (vla-get-TextGap obj) 2 lup))
     
156.                         (strcat        "垂直放置文字:"        (nth (vla-get-VerticalTextPosition obj) '("置中" "上方" "外部" "JIS")))
     
157.         ))
     
158.       )
     
159.       ((= name "LINE")
     
160.         (setq lst (list "【直线】"
     
161.                         (strcat "起点坐标:" (tran_zb 10))
     
162.                         (strcat "终点坐标:" (tran_zb 11))
     
163.                         (strcat "长度:" (rtos (vla-get-length obj) 2 lup))
     
164.                         (strcat "角度:" (tran_ang (vla-get-angle obj)))
     
165.         ))
     
166.       )
     
167.       ((= name "LWPOLYLINE")
     
168.         (setq n (fix (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (trans pt 1 0)))))
     
169.         (setq lst (list "【多段线】"
     
170.                         (strcat "常量宽度:" (if (dxf ent 43) (rtos (vla-get-ConstantWidth obj) 2 lup) "变宽度"))
     
171.                         (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))
     
172.                         (strcat "长度:" (rtos (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj)) 2 lup))
     
173.                         (strcat "面积:" (rtos (vla-get-Area obj) 2 lup))
     
174.                         (strcat "子线段长度:" (rtos (- (vlax-curve-getdistatparam obj (1+ n)) (vlax-curve-getdistatparam obj n)) 2 lup))
     
175.         ))
     
176.       )
     
177.       ((= name "MLINE")
     
178.         (setq lst (list "【多线】"
     
179.                         (strcat "多线样式:" (vla-get-StyleName obj))
     
180.                         (strcat "比例因子:" (rtos (dxf ent 40) 2 lup))
     
181.                         (strcat "对齐:" (nth (dxf ent 70) '("上" "无" "下")))
     
182.         ))
     
183.       )
     
184.       ((= name "MTEXT")
     
185.         (setq lst (list "【多行文字】"
     
186.                         (strcat "位置坐标:" (tran_zb 10))
     
187.                         (strcat "高度:" (rtos (vla-get-Height obj) 2 lup))
     
188.                         (strcat "角度:" (tran_ang (vla-get-Rotation obj)))
     
189.                         (strcat "宽度:" (rtos (vla-get-Width obj) 2 lup))
     
190.                         (strcat "样式:" (vla-get-StyleName obj))
     
191.                         (strcat        "对齐:"        (nth (1- (vla-get-AttachmentPoint obj))
     
192.                                           '("左上" "中上" "右上" "左中" "正中" "右中" "左下" "中下" "右下"))
     
193.                         )
     
194.         ))
     
195.       )
     
196.       ((or (= name "OLEFRAME") (= name "OLE2FRAME"))
     
197.         (setq lst (list "【OLE边框】"))
     
198.       )
     
199.       ((= name "POINT")
     
200.         (setq lst (list "【点】"
     
201.                         (strcat "位置坐标:" (tran_zb 10))
     
202.         ))
     
203.       )
     
204.       ((= name "POLYLINE")
     
205.         (cond
     
206.           ((= (vla-get-objectname obj) "AcDb3dPolyline")
     
207.             (setq n (fix (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (trans pt 1 0)))))
     
208.             (setq lst (list "【三维多段线】"
     
209.                             (strcat "多段线:" (if (= (logand (dxf ent 70) 1) 1) "闭合" "不闭合"))
     
210.                             (strcat "拟合:" (nth (vla-get-Type obj) '("无" "二次" "三次")))
     
211.                             (strcat "长度:" (rtos (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj)) 2 lup))
     
212.                             (strcat "子线段长度:" (rtos (- (vlax-curve-getdistatparam obj (1+ n)) (vlax-curve-getdistatparam obj n)) 2 lup))
     
213.             ))
     
214.           )
     
215.           ((= (vla-get-objectname obj) "AcDb2dPolyline")
     
216.             (setq n (fix (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (trans pt 1 0)))))
     
217.             (setq lst (list "【二维多段线】"
     
218.                             (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))
     
219.                             (strcat "拟合:" (nth (vla-get-Type obj) '("无" "拟合曲线" "二次" "三次")))
     
220.                             (strcat "长度:" (rtos (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj)) 2 lup))
     
221.                             (strcat "面积:" (rtos (vla-get-Area obj) 2 lup))
     
222.                             (strcat "子线段长度:" (rtos (- (vlax-curve-getdistatparam obj (1+ n)) (vlax-curve-getdistatparam obj n)) 2 lup))
     
223.             ))
     
224.           )
     
225.           (T
     
226.             (setq lst (list "【三维网格】"))
     
227.           )
     
228.         )
     
229.       )
     
230.       ((= name "RAY")
     
231.         (setq lst (list "【射线】"
     
232.                         (strcat "基点坐标:" (tran_zb 10))
     
233.         ))
     
234.       )
     
235.       ((= name "REGION")
     
236.         (setq lst (list "【面域】"
     
237.                         (strcat "周长:" (rtos (vla-get-Perimeter obj) 2 lup))
     
238.                         (strcat "面积:" (rtos (vla-get-Area obj) 2 lup))
     
239.                         (strcat "质心:" (tran_zb (vlax-safearray->list (vlax-variant-value (vla-get-Centroid obj)))))
     
240.                         (strcat "惯性矩:" (tran_zb (vlax-safearray->list (vlax-variant-value (vla-get-MomentOfInertia obj)))))
     
241.                         (strcat "旋转半径:" (tran_zb (vlax-safearray->list (vlax-variant-value (vla-get-RadiiOfGyration obj)))))
     
242.         ))
     
243.       )
     
244.       ((= name "SHAPE")
     
245.         (setq lst (list        "【形】"
     
246.                         (strcat "插入坐标:" (tran_zb 10))
     
247.                         (strcat "高度:" (rtos (vla-get-Height obj) 2 lup))
     
248.                         (strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 lup))
     
249.                         (strcat        "角度:"        (tran_ang (vla-get-Rotation obj)))
     
250.                         (strcat        "倾斜:"        (tran_ang (vla-get-ObliqueAngle obj)))
     
251.         ))
     
252.       )
     
253.       ((= name "SOLID")
     
254.         (setq lst (list "【实体】"))
     
255.       )
     
256.       ((= name "SPLINE")
     
257.         (setq lst (list "【样条曲线】"
     
258.                         (strcat "曲线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))
     
259.                         (strcat "平面:" (if (= (vla-get-IsPlanar obj) :vlax-false) "不是" "是"))
     
260.                         (strcat "阶数:" (rtos (vla-get-Degree obj) 2 0))
     
261.                         (strcat "拟合公差:" (rtos (vla-get-FitTolerance obj) 2 lup))
     
262.                         (strcat "长度:" (rtos (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj)) 2 lup))
     
263.                         (strcat "面积:" (if (= (vla-get-IsPlanar obj) :vlax-false) "无" (rtos (vla-get-Area obj) 2 lup)))
     
264.         ))
     
265.       )
     
266.       ((= name "TEXT")
     
267.         (setq lst (list "【文字】"
     
268.                         (strcat "位置坐标:" (tran_zb 10))
     
269.                         (strcat "高度:" (rtos (vla-get-Height obj) 2 lup))
     
270.                         (strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 lup))
     
271.                         (strcat        "角度:"        (tran_ang (vla-get-Rotation obj)))
     
272.                         (strcat "样式:" (vla-get-StyleName obj))
     
273.                         (strcat        "对齐:"        (nth (vla-get-Alignment obj)
     
274.                                           '("左" "中心" "右" "对齐" "中间" "调整" "左上" "中上"
     
275.                                             "右上" "左中" "正中" "右中" "左下" "中下" "右下"))
     
276.                         )
     
277.                         (strcat        "倾斜:"        (tran_ang (vla-get-ObliqueAngle obj)))
     
278.         ))
     
279.       )
     
280.       ((= name "TOLERANCE")
     
281.         (setq lst (list        "【公差】"
     
282.                         (strcat "位置坐标:" (tran_zb 10))
     
283.                         (strcat "标注样式:" (vla-get-StyleName obj))
     
284.                         (strcat "文字样式:" (vla-get-TextStyle obj))
     
285.                         (strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 lup))
     
286.         ))
     
287.       )
     
288.       ((= name "TRACE")
     
289.         (setq lst (list "【宽线】"))
     
290.       )
     
291.       ((= name "VERTEX")
     
292.         (setq lst (list "【顶点】"
     
293.                         (strcat "位置坐标:" (tran_zb 10))
     
294.                         (strcat "起始宽度:" (rtos (dxf ent 40) 2 lup))
     
295.                         (strcat "结束宽度:" (rtos (dxf ent 41) 2 lup))
     
296.                         (strcat "凸度:" (rtos (dxf ent 42) 2 lup))
     
297.         ))
     
298.       )
     
299.       ((= name "VIEWPORT")
     
300.         (setq lst (list "【视口】"
     
301.                         (strcat "中心坐标:" (tran_zb 10))
     
302.                         (strcat "宽度:" (rtos (vla-get-Width obj) 2 lup))
     
303.                         (strcat "高度:" (rtos (vla-get-Height obj) 2 lup))
     
304.         ))
     
305.       )
     
306.       ((= name "XLINE")
     
307.         (setq lst (list "【构造线】"
     
308.                         (strcat "基点坐标:" (tran_zb 10))
     
309.         ))
     
310.       )
     
311.       (T
     
312.         (setq lst (list "【未知对象】"))
     
313.       )
     
314.     )
     
315.     (setq lst (append (list (car lst)) (list laynm) (cdr lst))
     
316.           ss (ssadd)
     
317.           h (/ (getvar "viewsize") 60)
     
318.           high (* 1.7 h (length lst))
     
319.           width (* 0.75 h (apply 'max (mapcar 'strlen lst)))
     
320.           ang (angle (trans (getvar "viewctr") 1 2) (trans pt 1 2))
     
321.           pt (trans (mapcar '+ pt (getvar "target")) 1 2)
     
322.           ang (cond
     
323.                 ((>= (/ pi 2) ang 0)
     
324.                   (list (list (- (car pt) width) (- (cadr pt) high) (caddr pt)) (list (- (car pt) width) (cadr pt) (caddr pt)))
     
325.                 )
     
326.                 ((>= pi ang (/ pi 2))
     
327.                   (list (list (+ (car pt) width) (- (cadr pt) high) (caddr pt)) pt)
     
328.                 )
     
329.                 ((>= (+ pi (/ pi 2)) ang pi)
     
330.                   (list (list (+ (car pt) width) (+ (cadr pt) high) (caddr pt)) (list (car pt) (+ (cadr pt) high) (caddr pt)))
     
331.                 )
     
332.                 ((>= (* 2 pi) ang (+ pi (/ pi 2)))
     
333.                   (list (list (- (car pt) width) (+ (cadr pt) high) (caddr pt)) (list (- (car pt) width) (+ (cadr pt) high) (caddr pt)))
     
334.                 )
     
335.               )
     
336.     )
     
337.     (ssadd (add_solid pt (list (caar ang) (cadr pt) (caddr pt)) (list (car pt) (cadar ang) (caddr pt)) (car ang)) ss)
     
338.     (setq pt (cadr ang) pt (list (+ (car pt) (* 0.5 h)) (cadr pt) (caddr pt)))
     
339.     (setq n -1)
     
340.     (repeat (length lst)
     
341.       (ssadd (add_text (setq pt (list (car pt) (- (cadr pt) (* 1.6 h)) (caddr pt))) h (nth (setq n (1+ n)) lst)) ss)
     
342.     )
     
343.   )
     
344.   (vl-load-com)
     
345.   (setq acaddoc (vla-get-activedocument (vlax-get-acad-object)))
     
346.   (vla-startundomark acaddoc)
     
347.   (prompt "\n*** 鼠标移动查询信息，鼠标左键编辑，鼠标右键退出！***")
     
348.   (setq        olderr *error*
     
349.         *error* myerr
     
350.         oldvar (list (list "osmode" (getvar "osmode")) (list "fillmode" (getvar "fillmode")))
     
351.         ss (ssadd)
     
352.         loop T
     
353.   )
     
354.   (setvar "osmode" 0)
     
355.   (setvar "fillmode" 1)
     
356.   ;(if (not (tblsearch "style" "info"))
     
357.   ;  (progn
     
358.   ;    (setq newstyle (vla-add (vla-get-textstyles acaddoc) "info"))
     
359.   ;    (vla-put-fontfile newstyle "txt.shx")
     
360.   ;    (vla-put-bigfontfile newstyle "hztxt.shx")
     
361.   ;    (vlax-release-object newstyle)
     
362.   ;  )
     
363.   ;)
     
364.   (while loop
     
365.     (setq gr (grread T 8))
     
366.     (cond
     
367.       ((or (= (car gr) 12) (= (car gr) 5))
     
368.         (setq pt  (cadr gr)
     
369.               ent (nentselp pt)
     
370.               ent (if (and ent (= (type (last (last ent))) 'ename))
     
371.                     (last (last ent))
     
372.                     (car ent)
     
373.                   )
     
374.         )
     
375.         (if ent
     
376.           (if (not (or (equal ent oldent) (ssmemb ent ss)))
     
377.             (progn
     
378.               (del_ss ss)
     
379.               (if (and (= (dxf ent 0) "VERTEX") (dxf ent 330))
     
380.                 (setq ent (dxf ent 330))
     
381.               )
     
382.               (redraw ent 3)
     
383.               (dis_info ent)
     
384.               (setq oldent ent)
     
385.             )
     
386.           )
     
387.           (progn
     
388.             (del_ss ss)
     
389.             (setq oldent nil ss (ssadd))
     
390.           )
     
391.         )
     
392.       )
     
393.       ((= (car gr) 3)
     
394.         (if oldent
     
395.           (if (= (getvar "cmdnames") "")
     
396.             (progn
     
397.               (sssetfirst nil (ssadd oldent))
     
398.               (vl-cmdf "_.properties")
     
399.             )
     
400.             (prompt "\n透明调用时无法编辑！")
     
401.           )
     
402.         )
     
403.       )
     
404.       (T (setq loop nil))
     
405.     )
     
406.   )
     
407.   (del_ss ss)
     
408.   (if (or (= (car gr) 12) (= (car gr) 25)) (sssetfirst))
     
409.   (setq *error* olderr)
     
410.   (foreach itm oldvar (setvar (car itm) (cadr itm)))
     
411.   (vla-endundomark acaddoc)
     
412.   (vlax-release-object acaddoc)
     
413.   (princ)
     
414. )
     
415. (setvar "cmdecho" 0)
     
416. (if (not (tblsearch "style" "info"))
     
417.   (progn
     
418.     (setq oldtxtsty (getvar "textstyle"))
     
419.     (vl-cmdf "_.style" "info" "宋体" "0" "1" "0" "n" "n")
     
420.     (setvar "textstyle" oldtxtsty)
     
421.     (setq oldtxtsty nil)
     
422.   )
     
423. )
     
424. (prompt "\n*** 使用命令：info或'info透明调用 ***")
     
425. (princ)

;;<br /> ;;功能：动态查询信息<br /> ;;文件：info.lsp<br /> ;;命令：info或'info透明调用<br /> ;;使用：鼠标移动查询信息，鼠标左键编辑，鼠标右键退出<br /> ;;作者：YAD<br /> ;;<br /> <br /> (defun c:info (/ myerr dxf del_ss tran_ang tran_zb add_solid add_text dis_info<br />                  acaddoc olderr oldvar ss loop gr pt ent oldent)<br />   (defun myerr (msg)<br />     (del_ss ss)<br />     (setq *error* olderr)<br />   )<br />   (defun dxf (ent n)<br />     (if        (= (type ent) 'ename)<br />       (setq ent (entget ent))<br />     )<br />     (cdr (assoc n ent))<br />   )<br />   (defun del_ss (ss / n)<br />     (setq n -1)<br />     (repeat (sslength ss)<br />       (entdel (ssname ss (setq n (1+ n))))<br />     )<br />     (if oldent (redraw oldent 4))<br />   )<br />   (defun tran_ang (ang)<br />     (strcat (rtos (* ang (/ 180 pi)) 2 (getvar "auprec")) "度")<br />   )<br />   (defun tran_zb (nm / zb)<br />     (if (= (type nm) 'int) (setq zb (dxf ent nm)) (setq zb nm))<br />     (strcat (rtos (car zb) 2 lup) "," (rtos (cadr zb) 2 lup) (if (caddr zb) (strcat "," (rtos (caddr zb) 2 lup)) ""))<br />   )<br />   (defun add_solid (p1 p2 p3 p4)<br />     (entmakex (list (cons 0 "SOLID") (cons 100 "AcDbEntity") (cons 62 1) (cons 100 "AcDbTrace")<br />                     (cons 10 p1)(cons 11 p2) (cons 12 p3) (cons 13 p4) (cons 210 (trans (getvar "viewdir") 1 0))<br />     ))<br />   )<br />   (defun add_text (pt h txt)<br />     (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 62 2) (cons 100 "AcDbText")<br />                     (cons 10 pt) (cons 40 h) (cons 1 txt) (cons 50 0.0) (cons 7 "info") (cons 72 0) (cons 73 0)<br />                     (cons 210 (trans (getvar "viewdir") 1 0))<br />     ))<br />   )<br />   (defun dis_info (ent / obj laynm name lup lst h high width ang n)<br />     (setq obj (vlax-ename->vla-object ent)<br />           laynm        (strcat "图层:" (dxf ent 8))<br />           name        (dxf ent 0)<br />           lup (getvar "luprec")<br />     )<br />     (cond                          ;;*****以下内容可以根据个人需要按格式调整*****<br />       ((= name "3DFACE")<br />         (setq lst (list "【三维面】"))<br />       )<br />       ((= name "3DSOLID")<br />         (setq lst (list "【三维实体】"<br />                         (strcat "质心:" (tran_zb (vlax-safearray->list (vlax-variant-value (vla-get-Centroid obj)))))<br />                         (strcat "惯性矩:" (tran_zb (vlax-safearray->list (vlax-variant-value (vla-get-MomentOfInertia obj)))))<br />                         (strcat "旋转半径:" (tran_zb (vlax-safearray->list (vlax-variant-value (vla-get-RadiiOfGyration obj)))))<br />         ))<br />       )<br />       ((= name "ACAD_PROXY_ENTITY")<br />         (setq lst (list "【代理】"))<br />       )<br />       ((= name "ARC")<br />         (setq lst (list "【圆弧】"<br />                         (strcat "圆心坐标:" (tran_zb 10))<br />                         (strcat "半径:"   (rtos (vla-get-radius obj) 2 lup))<br />                         (strcat "圆心角:" (tran_ang (vla-get-TotalAngle obj)))<br />                         (strcat "起始角:" (tran_ang (vla-get-StartAngle obj)))<br />                         (strcat "终止角:" (tran_ang (vla-get-EndAngle obj)))<br />                         (strcat "总弧长:" (rtos (vla-get-ArcLength obj) 2 lup))<br />                         (strcat "面积:"   (rtos (vla-get-Area obj) 2 lup))<br />         ))<br />       )<br />       ((= name "ATTDEF")<br />         (setq lst (list "【属性定义】"<br />                         (strcat "位置坐标:" (tran_zb 10))<br />                         (strcat "标签:" (vla-get-TagString obj))<br />                         (strcat "提示:" (vla-get-PromptString obj))<br />                         (strcat "缺省值:" (vla-get-TextString obj))<br />                         (strcat "高度:" (rtos (vla-get-Height obj) 2 lup))<br />                         (strcat "角度:" (tran_ang (vla-get-Rotation obj)))<br />                         (strcat "文字样式:" (vla-get-StyleName obj))<br />         ))<br />       )<br />       ((= name "ATTRIB")<br />         (setq lst (list "【属性】"<br />                         (strcat "位置坐标:" (tran_zb 10))<br />                         (strcat "标签:" (vla-get-TagString obj))<br />                         (strcat "缺省值:" (vla-get-TextString obj))<br />                         (strcat "高度:" (rtos (vla-get-Height obj) 2 lup))<br />                         (strcat "角度:" (tran_ang (vla-get-Rotation obj)))<br />                         (strcat "文字样式:" (vla-get-StyleName obj))<br />         ))<br />       )<br />       ((= name "CIRCLE")<br />         (setq lst (list "【圆】"<br />                         (strcat "圆心坐标:" (tran_zb 10))<br />                         (strcat "半径:" (rtos (vla-get-radius obj) 2 lup))<br />                         (strcat "周长:" (rtos (vla-get-Circumference obj) 2 lup))<br />                         (strcat "面积:" (rtos (vla-get-Area obj) 2 lup))<br />         ))<br />       )<br />       ((= name "DIMENSION")<br />         (setq lst (list "【尺寸标注】"<br />                         (strcat "标注样式:" (vla-get-StyleName obj))<br />                         (strcat "文字样式:" (vla-get-TextStyle obj))<br />                         (strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 lup))<br />                         (strcat        "替带文字:" (if (= (dxf ent 1) "") "无" (dxf ent 1)))<br />         ))<br />       )<br />       ((= name "ELLIPSE")<br />         (setq lst (list        "【椭圆】"<br />                         (strcat "圆心坐标:" (tran_zb 10))<br />                         (strcat "长轴半径:" (rtos (vla-get-MajorRadius obj) 2 lup))<br />                         (strcat "短轴半径:" (rtos (vla-get-MinorRadius obj) 2 lup))<br />                         (strcat        "起始角:" (tran_ang (vla-get-StartAngle obj)))<br />                         (strcat        "终止角:" (tran_ang (vla-get-EndAngle obj)))<br />                         (strcat "周长:" (rtos (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj)) 2 lup))<br />                         (strcat        "面积:"        (rtos (vla-get-Area obj) 2 lup))<br />         ))<br />       )<br />       ((= name "HATCH")<br />         (setq lst (list        "【图案填充】"<br />                         (strcat "图案名称:" (vla-get-PatternName obj))<br />                         (strcat        "角度:"        (tran_ang (vla-get-PatternAngle obj)))<br />                         (strcat "比例:" (rtos (vla-get-PatternScale obj) 2 lup))<br />                         (strcat "关联:" (if (= (vla-get-AssociativeHatch obj) :vlax-false) "关闭" "打开"))<br />                         (strcat "填充样式:" (nth (vla-get-HatchStyle obj) '("普通" "外部" "忽略")))<br />         ))<br />       )<br />       ((= name "IMAGE")<br />         (setq lst (list "【图像】"<br />                         (strcat "插入坐标:" (tran_zb 10))<br />                         (strcat "图像大小:" (rtos (car (dxf ent 13)) 2 lup) "X" (rtos (cadr (dxf ent 13)) 2 lup))<br />         ))<br />       )<br />       ((= name "INSERT")<br />         (setq lst (list "【图块】"<br />                         (strcat "插入坐标:" (tran_zb 10))<br />                         (strcat "名称:" (vla-get-Name obj))<br />                         (strcat "X比例:" (rtos (vla-get-XScaleFactor obj) 2 lup))<br />                         (strcat "Y比例:" (rtos (vla-get-YScaleFactor obj) 2 lup))<br />                         (strcat "Z比例:" (rtos (vla-get-ZScaleFactor obj) 2 lup))<br />                         (strcat "角度:" (tran_ang (vla-get-Rotation obj)))<br />         ))<br />       )<br />       ((= name "LEADER")<br />         (setq lst (list "【引线】"<br />                         (strcat "标注样式:" (vla-get-StyleName obj))<br />                         (strcat "引线类型:" (nth (vla-get-Type obj) '("无箭头直线" "无箭头曲线" "箭头直线" "箭头曲线")))<br />                         (strcat "文字偏移:" (rtos (vla-get-TextGap obj) 2 lup))<br />                         (strcat        "垂直放置文字:"        (nth (vla-get-VerticalTextPosition obj) '("置中" "上方" "外部" "JIS")))<br />         ))<br />       )<br />       ((= name "LINE")<br />         (setq lst (list "【直线】"<br />                         (strcat "起点坐标:" (tran_zb 10))<br />                         (strcat "终点坐标:" (tran_zb 11))<br />                         (strcat "长度:" (rtos (vla-get-length obj) 2 lup))<br />                         (strcat "角度:" (tran_ang (vla-get-angle obj)))<br />         ))<br />       )<br />       ((= name "LWPOLYLINE")<br />         (setq n (fix (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (trans pt 1 0)))))<br />         (setq lst (list "【多段线】"<br />                         (strcat "常量宽度:" (if (dxf ent 43) (rtos (vla-get-ConstantWidth obj) 2 lup) "变宽度"))<br />                         (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))<br />                         (strcat "长度:" (rtos (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj)) 2 lup))<br />                         (strcat "面积:" (rtos (vla-get-Area obj) 2 lup))<br />                         (strcat "子线段长度:" (rtos (- (vlax-curve-getdistatparam obj (1+ n)) (vlax-curve-getdistatparam obj n)) 2 lup))<br />         ))<br />       )<br />       ((= name "MLINE")<br />         (setq lst (list "【多线】"<br />                         (strcat "多线样式:" (vla-get-StyleName obj))<br />                         (strcat "比例因子:" (rtos (dxf ent 40) 2 lup))<br />                         (strcat "对齐:" (nth (dxf ent 70) '("上" "无" "下")))<br />         ))<br />       )<br />       ((= name "MTEXT")<br />         (setq lst (list "【多行文字】"<br />                         (strcat "位置坐标:" (tran_zb 10))<br />                         (strcat "高度:" (rtos (vla-get-Height obj) 2 lup))<br />                         (strcat "角度:" (tran_ang (vla-get-Rotation obj)))<br />                         (strcat "宽度:" (rtos (vla-get-Width obj) 2 lup))<br />                         (strcat "样式:" (vla-get-StyleName obj))<br />                         (strcat        "对齐:"        (nth (1- (vla-get-AttachmentPoint obj))<br />                                           '("左上" "中上" "右上" "左中" "正中" "右中" "左下" "中下" "右下"))<br />                         )<br />         ))<br />       )<br />       ((or (= name "OLEFRAME") (= name "OLE2FRAME"))<br />         (setq lst (list "【OLE边框】"))<br />       )<br />       ((= name "POINT")<br />         (setq lst (list "【点】"<br />                         (strcat "位置坐标:" (tran_zb 10))<br />         ))<br />       )<br />       ((= name "POLYLINE")<br />         (cond<br />           ((= (vla-get-objectname obj) "AcDb3dPolyline")<br />             (setq n (fix (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (trans pt 1 0)))))<br />             (setq lst (list "【三维多段线】"<br />                             (strcat "多段线:" (if (= (logand (dxf ent 70) 1) 1) "闭合" "不闭合"))<br />                             (strcat "拟合:" (nth (vla-get-Type obj) '("无" "二次" "三次")))<br />                             (strcat "长度:" (rtos (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj)) 2 lup))<br />                             (strcat "子线段长度:" (rtos (- (vlax-curve-getdistatparam obj (1+ n)) (vlax-curve-getdistatparam obj n)) 2 lup))<br />             ))<br />           )<br />           ((= (vla-get-objectname obj) "AcDb2dPolyline")<br />             (setq n (fix (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (trans pt 1 0)))))<br />             (setq lst (list "【二维多段线】"<br />                             (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))<br />                             (strcat "拟合:" (nth (vla-get-Type obj) '("无" "拟合曲线" "二次" "三次")))<br />                             (strcat "长度:" (rtos (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj)) 2 lup))<br />                             (strcat "面积:" (rtos (vla-get-Area obj) 2 lup))<br />                             (strcat "子线段长度:" (rtos (- (vlax-curve-getdistatparam obj (1+ n)) (vlax-curve-getdistatparam obj n)) 2 lup))<br />             ))<br />           )<br />           (T<br />             (setq lst (list "【三维网格】"))<br />           )<br />         )<br />       )<br />       ((= name "RAY")<br />         (setq lst (list "【射线】"<br />                         (strcat "基点坐标:" (tran_zb 10))<br />         ))<br />       )<br />       ((= name "REGION")<br />         (setq lst (list "【面域】"<br />                         (strcat "周长:" (rtos (vla-get-Perimeter obj) 2 lup))<br />                         (strcat "面积:" (rtos (vla-get-Area obj) 2 lup))<br />                         (strcat "质心:" (tran_zb (vlax-safearray->list (vlax-variant-value (vla-get-Centroid obj)))))<br />                         (strcat "惯性矩:" (tran_zb (vlax-safearray->list (vlax-variant-value (vla-get-MomentOfInertia obj)))))<br />                         (strcat "旋转半径:" (tran_zb (vlax-safearray->list (vlax-variant-value (vla-get-RadiiOfGyration obj)))))<br />         ))<br />       )<br />       ((= name "SHAPE")<br />         (setq lst (list        "【形】"<br />                         (strcat "插入坐标:" (tran_zb 10))<br />                         (strcat "高度:" (rtos (vla-get-Height obj) 2 lup))<br />                         (strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 lup))<br />                         (strcat        "角度:"        (tran_ang (vla-get-Rotation obj)))<br />                         (strcat        "倾斜:"        (tran_ang (vla-get-ObliqueAngle obj)))<br />         ))<br />       )<br />       ((= name "SOLID")<br />         (setq lst (list "【实体】"))<br />       )<br />       ((= name "SPLINE")<br />         (setq lst (list "【样条曲线】"<br />                         (strcat "曲线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))<br />                         (strcat "平面:" (if (= (vla-get-IsPlanar obj) :vlax-false) "不是" "是"))<br />                         (strcat "阶数:" (rtos (vla-get-Degree obj) 2 0))<br />                         (strcat "拟合公差:" (rtos (vla-get-FitTolerance obj) 2 lup))<br />                         (strcat "长度:" (rtos (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj)) 2 lup))<br />                         (strcat "面积:" (if (= (vla-get-IsPlanar obj) :vlax-false) "无" (rtos (vla-get-Area obj) 2 lup)))<br />         ))<br />       )<br />       ((= name "TEXT")<br />         (setq lst (list "【文字】"<br />                         (strcat "位置坐标:" (tran_zb 10))<br />                         (strcat "高度:" (rtos (vla-get-Height obj) 2 lup))<br />                         (strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 lup))<br />                         (strcat        "角度:"        (tran_ang (vla-get-Rotation obj)))<br />                         (strcat "样式:" (vla-get-StyleName obj))<br />                         (strcat        "对齐:"        (nth (vla-get-Alignment obj)<br />                                           '("左" "中心" "右" "对齐" "中间" "调整" "左上" "中上"<br />                                             "右上" "左中" "正中" "右中" "左下" "中下" "右下"))<br />                         )<br />                         (strcat        "倾斜:"        (tran_ang (vla-get-ObliqueAngle obj)))<br />         ))<br />       )<br />       ((= name "TOLERANCE")<br />         (setq lst (list        "【公差】"<br />                         (strcat "位置坐标:" (tran_zb 10))<br />                         (strcat "标注样式:" (vla-get-StyleName obj))<br />                         (strcat "文字样式:" (vla-get-TextStyle obj))<br />                         (strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 lup))<br />         ))<br />       )<br />       ((= name "TRACE")<br />         (setq lst (list "【宽线】"))<br />       )<br />       ((= name "VERTEX")<br />         (setq lst (list "【顶点】"<br />                         (strcat "位置坐标:" (tran_zb 10))<br />                         (strcat "起始宽度:" (rtos (dxf ent 40) 2 lup))<br />                         (strcat "结束宽度:" (rtos (dxf ent 41) 2 lup))<br />                         (strcat "凸度:" (rtos (dxf ent 42) 2 lup))<br />         ))<br />       )<br />       ((= name "VIEWPORT")<br />         (setq lst (list "【视口】"<br />                         (strcat "中心坐标:" (tran_zb 10))<br />                         (strcat "宽度:" (rtos (vla-get-Width obj) 2 lup))<br />                         (strcat "高度:" (rtos (vla-get-Height obj) 2 lup))<br />         ))<br />       )<br />       ((= name "XLINE")<br />         (setq lst (list "【构造线】"<br />                         (strcat "基点坐标:" (tran_zb 10))<br />         ))<br />       )<br />       (T<br />         (setq lst (list "【未知对象】"))<br />       )<br />     )<br />     (setq lst (append (list (car lst)) (list laynm) (cdr lst))<br />           ss (ssadd)<br />           h (/ (getvar "viewsize") 60)<br />           high (* 1.7 h (length lst))<br />           width (* 0.75 h (apply 'max (mapcar 'strlen lst)))<br />           ang (angle (trans (getvar "viewctr") 1 2) (trans pt 1 2))<br />           pt (trans (mapcar '+ pt (getvar "target")) 1 2)<br />           ang (cond<br />                 ((>= (/ pi 2) ang 0)<br />                   (list (list (- (car pt) width) (- (cadr pt) high) (caddr pt)) (list (- (car pt) width) (cadr pt) (caddr pt)))<br />                 )<br />                 ((>= pi ang (/ pi 2))<br />                   (list (list (+ (car pt) width) (- (cadr pt) high) (caddr pt)) pt)<br />                 )<br />                 ((>= (+ pi (/ pi 2)) ang pi)<br />                   (list (list (+ (car pt) width) (+ (cadr pt) high) (caddr pt)) (list (car pt) (+ (cadr pt) high) (caddr pt)))<br />                 )<br />                 ((>= (* 2 pi) ang (+ pi (/ pi 2)))<br />                   (list (list (- (car pt) width) (+ (cadr pt) high) (caddr pt)) (list (- (car pt) width) (+ (cadr pt) high) (caddr pt)))<br />                 )<br />               )<br />     )<br />     (ssadd (add_solid pt (list (caar ang) (cadr pt) (caddr pt)) (list (car pt) (cadar ang) (caddr pt)) (car ang)) ss)<br />     (setq pt (cadr ang) pt (list (+ (car pt) (* 0.5 h)) (cadr pt) (caddr pt)))<br />     (setq n -1)<br />     (repeat (length lst)<br />       (ssadd (add_text (setq pt (list (car pt) (- (cadr pt) (* 1.6 h)) (caddr pt))) h (nth (setq n (1+ n)) lst)) ss)<br />     )<br />   )<br />   (vl-load-com)<br />   (setq acaddoc (vla-get-activedocument (vlax-get-acad-object)))<br />   (vla-startundomark acaddoc)<br />   (prompt "\n*** 鼠标移动查询信息，鼠标左键编辑，鼠标右键退出！***")<br />   (setq        olderr *error*<br />         *error* myerr<br />         oldvar (list (list "osmode" (getvar "osmode")) (list "fillmode" (getvar "fillmode")))<br />         ss (ssadd)<br />         loop T<br />   )<br />   (setvar "osmode" 0)<br />   (setvar "fillmode" 1)<br />   ;(if (not (tblsearch "style" "info"))<br />   ;  (progn<br />   ;    (setq newstyle (vla-add (vla-get-textstyles acaddoc) "info"))<br />   ;    (vla-put-fontfile newstyle "txt.shx")<br />   ;    (vla-put-bigfontfile newstyle "hztxt.shx")<br />   ;    (vlax-release-object newstyle)<br />   ;  )<br />   ;)<br />   (while loop<br />     (setq gr (grread T 8))<br />     (cond<br />       ((or (= (car gr) 12) (= (car gr) 5))<br />         (setq pt  (cadr gr)<br />               ent (nentselp pt)<br />               ent (if (and ent (= (type (last (last ent))) 'ename))<br />                     (last (last ent))<br />                     (car ent)<br />                   )<br />         )<br />         (if ent<br />           (if (not (or (equal ent oldent) (ssmemb ent ss)))<br />             (progn<br />               (del_ss ss)<br />               (if (and (= (dxf ent 0) "VERTEX") (dxf ent 330))<br />                 (setq ent (dxf ent 330))<br />               )<br />               (redraw ent 3)<br />               (dis_info ent)<br />               (setq oldent ent)<br />             )<br />           )<br />           (progn<br />             (del_ss ss)<br />             (setq oldent nil ss (ssadd))<br />           )<br />         )<br />       )<br />       ((= (car gr) 3)<br />         (if oldent<br />           (if (= (getvar "cmdnames") "")<br />             (progn<br />               (sssetfirst nil (ssadd oldent))<br />               (vl-cmdf "_.properties")<br />             )<br />             (prompt "\n透明调用时无法编辑！")<br />           )<br />         )<br />       )<br />       (T (setq loop nil))<br />     )<br />   )<br />   (del_ss ss)<br />   (if (or (= (car gr) 12) (= (car gr) 25)) (sssetfirst))<br />   (setq *error* olderr)<br />   (foreach itm oldvar (setvar (car itm) (cadr itm)))<br />   (vla-endundomark acaddoc)<br />   (vlax-release-object acaddoc)<br />   (princ)<br /> )<br /> (setvar "cmdecho" 0)<br /> (if (not (tblsearch "style" "info"))<br />   (progn<br />     (setq oldtxtsty (getvar "textstyle"))<br />     (vl-cmdf "_.style" "info" "宋体" "0" "1" "0" "n" "n")<br />     (setvar "textstyle" oldtxtsty)<br />     (setq oldtxtsty nil)<br />   )<br /> )<br /> (prompt "\n*** 使用命令：info或'info透明调用 ***")<br /> (princ)

st788796

这些只用ctrl+1

lff763

st788796 发表于 2015-1-3 19:30
这些只用ctrl+1

什么意思。。。。

st788796

  角度修改这里
(defun tran_ang (ang)
    (strcat (rtos (* ang (/ 180 pi)) 2 (getvar "auprec")) "度")
找这段修改长度
((= name "LINE")

xtdwynij

lff763 发表于 2015-1-3 16:44

赞！6666高手！！