★★★★动态信息查询（精简+注释版）,给初学者~~~
;---------------------------------------------------------------------------------------------------------------------; ★动态信息查询（精简+注释版）
; ★版权归原作者所有,精简目的只是让初学者更容易看懂
;---------------------------------------------------------------------------------------------------------------------
(defun C:tt (/ myerr fx add_solid add_tex dis olderr oldos oldfill ss pd gr pt ent entold)
(defun myerr (msg)
(setq *error* olderr)
(command "_.undo" "_b")
(princ)
)
;画矩形提示框
(defun add_solid (p1 p2 p3 p4)
(entmakex (list (cons 0 "SOLID")
(cons 100 "AcDbEntity")
(cons 62 8);提示框背景颜色
(cons 100 "AcDbTrace")
(cons 10 p1)
(cons 11 p2)
(cons 12 p3)
(cons 13 p4)
)
)
)
;写列表文本
(defun add_text (pt h ang txt style jus)
(entmakex (list
(cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 62 7);提示框字体颜色
(cons 100 "AcDbText")
(cons 10 pt)
(cons 40 h)
(cons 1 txt)
(cons 7 style)
)
)
)
;处理子程序
(defun dis (ent / obj laynm name lst h n)
(setq obj (vlax-ename->vla-object ent)
laynm(strcat "图层:" (vlax-get obj 'Layer))
name(vlax-get obj 'ObjectName)
)
(cond
((= name "AcDbLine");图元为直线时执行,若使用者需要增加功能,在cond里面添加即可~
(setq lst (list
"【直线】"
laynm
(strcat "长度:" (rtos (vlax-get obj 'Length) 2 0))
)
)
)
((= name "AcDbPolyline");图元为多段线执行
(setq lst (list
"【多段线】"
laynm
(strcat "多段线:"
(if (= (vla-get-Closed obj) :vlax-false)
"不闭合"
"闭合"
)
)
(strcat "面积:" (rtos (vlax-get obj 'Area) 2 2))
)
)
)
(T
(setq lst (list "【暂不支持】" laynm))
)
);cond
(setq ss (ssadd)
h (/ (getvar "viewsize") 60);视图大小,修改"60"可以调整提示框大小
n (* 1.4 (1+ (/ (apply 'max (mapcar 'strlen lst)) 2.0)));最长字符串决定提示框最大宽度
)
(ssadd
(add_solid
pt
(polar pt 0 (* n h))
(setq pt1 (polar pt (* pi 1.5) (+ h (* 1.6 h (length lst)))));表长度决定提示框高度
(polar pt1 0 (* n h))
)
ss
)
(setq pt (polar pt 0 (* n h 0.1)))
(setq n -1)
(repeat (length lst);repeat
(ssadd
(add_text
(setq pt (polar pt (* pi 1.5) (* 1.6 h)))
h
0
(nth (setq n (1+ n)) lst)
"新宋体"
1
)
ss
)
);repeat
)
;开始程序=======================================================================*
(vl-load-com)
(command "_.undo" "_m")
(prompt "\n***移动鼠标掠过对象查看信息！***")
(setqolderr*error*
*error*myerr
)
(setq oldos (getvar "osmode"))
(setq oldfill (getvar "fillmode"))
(setvar "osmode" 0)
(setvar "fillmode" 1)
(setvar "cmdecho" 0)
(if (not (tblsearch "style" "新宋体"))
(command "_.style" "新宋体" "新宋体" "" "" "" "" "")
)
;-------------(开始)前处理完毕--------------------------------------------
(setq ss (ssadd))
(while (not pd);while1
(while ;while
(not (progn
(setq gr (grread T 1));鼠标动作
(if (= (car gr) 5)
(setq pt(cadr gr);鼠标坐标
ent (nentselp pt);选择物件
ent (if (and ent (= (type (last (last ent))) 'ename))
(last (last ent))
(car ent)
)
)
(setq pd T)
);if
)
)
);while2
(if (and (not pd) (not (equal ent entold)) (not (ssmemb ent ss)))
(progn
(if entold (redraw entold 4))
(if ss (command "_.erase" ss ""))
(redraw ent 3)
(dis ent)
(setq entold ent)
)
)
);while1
(if entold (redraw entold 4))
(if ss (command "_.erase" ss ""))
(setvar "osmode" oldos)
(setvar "fillmode" oldfill)
(setq *error* olderr)
(princ)
);defun
(prompt "\n ★★★★动态信息查询（精简+注释版）\n ★★★★版权归原作者所有,精简目的只是让初学者更容易看懂 \n")
(princ)★★★★动态信息查询（精简+注释版） ★★★★版权归原作者所有,精简目的只是让初学者更容易看懂
这个好使.！学习了。 这个好使.！学习了。 好用， 不错！！！！！！ 出彩，真的狠精彩，学习了。 程序不错，谢谢了
初学者的 好老师 支持了 07用不了？ 只能查看直线 meja 发表于 2014-7-12 11:15 static/image/common/back.gif
只能查看直线
这个是精简出来给大家更容易看清代码的，完整的论坛里面有。如果你是要实用性，最好去下载人家原来那个！
页:
[1]
2