★★★★动态信息查询（精简+注释版）,给初学者~~~

77077 · 发表于 2014-7-2 17:34:52

;---------------------------------------------------------------------------------------------------------------------
; ★动态信息查询（精简+注释版）
; ★版权归原作者所有,精简目的只是让初学者更容易看懂
;---------------------------------------------------------------------------------------------------------------------
(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***移动鼠标掠过对象查看信息！***")
(setq olderr *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)

;--------------------------------------------------------------------------------------------------------------------- 
; ★动态信息查询（精简+注释版） 
; ★版权归原作者所有,精简目的只是让初学者更容易看懂 
;--------------------------------------------------------------------------------------------------------------------- 
(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***移动鼠标掠过对象查看信息！***") 
  (setq  olderr  *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)

★★★★动态信息查询（精简+注释版） ★★★★版权归原作者所有,精简目的只是让初学者更容易看懂

paulpipi · 发表于 2019-11-21 23:37:18

这个好使.！学习了。

434939575 · 发表于 2014-7-2 19:34:51

这个好使.！学习了。

qyming · 发表于 2014-7-2 20:47:12

好用，

spp_wall · 发表于 2014-7-3 08:16:01

不错！！！！！！

cooolseee · 发表于 2014-7-7 08:36:47

出彩，真的狠精彩，学习了。

ps122hb · 发表于 2014-7-8 08:16:57

程序不错，谢谢了

杜阳 · 发表于 2014-7-8 13:42:08

初学者的好老师支持了

qyming · 发表于 2014-7-10 09:31:16

07用不了？

meja · 发表于 2014-7-12 11:15:30

只能查看直线

77077 · 发表于 2014-7-12 11:59:52

meja 发表于 2014-7-12 11:15
只能查看直线

这个是精简出来给大家更容易看清代码的，完整的论坛里面有。如果你是要实用性，最好去下载人家原来那个！

账号		自动登录	找回密码
密码			注册

[源码] ★★★★动态信息查询（精简+注释版）,给初学者~~~

相关帖子