[原创]：动态查询信息程序

lyy

;;
;;功能：动态查询信息
;;文件：info.lsp
;;命令：info
;;作者：YAD
;;时间：2003.8
;;

(defun C:info(/ myerr dxf toang fx add_solid add_text dis olderr oldos oldfill ss pd gr pt ent entold)
  (defun myerr(msg)
    (setq *error* olderr)
    (command "_.undo" "_b")
    (princ)
  )
  (defun dxf(ent i)
    (if (= (type ent) 'ename)
      (setq ent (entget ent))
    )
    (cdr (assoc i ent))
  )
  (defun toang(ang i)
    (if (= i 1)
      (* ang (/ 180 pi))
      (* ang (/ pi 180))
    )
  )
  (defun fx(ang)
    (cond
      ((>= (/ pi 2) ang 0) (list pi (+ pi (/ pi 2)) 1))
      ((>= pi ang (/ pi 2)) (list 0 (+ pi (/ pi 2)) 1))
      ((>= (+ pi (/ pi 2)) ang pi) (list 0 (/ pi 2) 0))
      ((>= (* 2 pi) ang (+ pi (/ pi 2))) (list pi (/ pi 2) 0))
    )
  )
  (defun add_solid(p1 p2 p3 p4)
    (entmakex (list (cons 0 "SOLID") (cons 100 "AcDbEntity") (cons 62 1) (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 2) (cons 100 "AcDbText") (if (= jus 0) (cons 10 pt) (list 10 0.0 0.0 0.0)) (cons 40 h)
                    (cons 1 txt) (cons 50 ang) (cons 7 style) (cons 72 (cond ((= jus 0) 0) ((= jus 1) 1) ((= jus 2) 1) ((= jus 3) 2))) (if (= jus 0)
                    (list 11 0.0 0.0 0.0) (cons 11 pt)) (cons 100 "AcDbText") (cons 73 (cond ((= jus 0) 0) ((= jus 1) 2) ((= jus 2) 3) ((= jus 3) 2)))
              )
    )
  )
  (defun dis(ent / obj laynm name st1 st2 st3 lst h ang n)
    (setq obj (vlax-ename->vla-object ent))
    (setq laynm (strcat "图层:" (dxf ent 8)) name (dxf ent 0))
    (cond
      ((= name "3DFACE")
        (setq lst (list "【三维面】" laynm))
      )
      ((= name "3DSOLID")
        (setq lst (list "【三维实体】" laynm (strcat "格式版本号:" (itoa (dxf ent 70)))))
      )
      ((= name "ACAD_PROXY_ENTITY")
        (setq lst (list "【代理】" laynm))
      )
      ((= name "ARC")
        (setq lst (list "【圆弧】" laynm (strcat "半径:" (rtos (vla-get-radius obj) 2 0))
                                         (strcat "圆心角:" (rtos (toang (vla-get-TotalAngle obj) 1) 2 1) "度")
                                         (strcat "起始角:" (rtos (toang (vla-get-StartAngle obj) 1) 2 1) "度")
                                         (strcat "终止角:" (rtos (toang (vla-get-EndAngle obj) 1) 2 1) "度")
                                         (strcat "总弧长:" (rtos (vla-get-ArcLength obj) 2 0))
                                         (strcat "面积:" (rtos (/ (vla-get-Area obj) 1000000) 2 2) "㎡")
        ))
      )
      ((= name "ATTDEF")
        (setq lst (list "【属性定义】" laynm (strcat "标签:" (vla-get-TagString obj))
                                             (strcat "提示:" (vla-get-PromptString obj))
                                             (strcat "缺省值:" (vla-get-TextString obj))
                                             (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
                                             (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
                                             (strcat "文字样式:" (vla-get-StyleName obj))
        ))
      )
      ((= name "ATTRIB")
        (setq lst (list "【属性】" laynm (strcat "标签:" (vla-get-TagString obj))
                                         (strcat "缺省值:" (vla-get-TextString obj))
                                         (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
                                         (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
                                         (strcat "文字样式:" (vla-get-StyleName obj))
        ))
      )
      ((= name "BODY")
        (setq lst (list "【体】" laynm (strcat "格式版本号:" (itoa (dxf ent 70)))))
      )
      ((= name "CIRCLE")
        (setq lst (list "【圆】" laynm (strcat "半径:" (rtos (vla-get-radius obj) 2 0))
                                       (strcat "周长:" (rtos (vla-get-Circumference obj) 2 0))
                                       (strcat "面积:" (rtos (/ (vla-get-Area obj) 1000000) 2 2) "㎡")
        ))
      )
      ((= name "DIMENSION")
        (setq lst (list "【尺寸标注】" laynm (strcat "标注样式:" (vla-get-StyleName obj))
                                             (strcat "文字样式:" (vla-get-TextStyle obj))
                                             (strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 1))
                                             (strcat "替带文字:" (if (= (dxf ent 1) "") "无" (dxf ent 1)))
        ))
      )
      ((= name "ELLIPSE")
        (setq lst (list "【椭圆】" laynm (strcat "长轴半径:" (rtos (vla-get-MajorRadius obj) 2 0))
                                         (strcat "短轴半径:" (rtos (vla-get-MinorRadius obj) 2 0))
                                         (strcat "起始角:" (rtos (toang (vla-get-StartAngle obj) 1) 2 1) "度")
                                         (strcat "终止角:" (rtos (toang (vla-get-EndAngle obj) 1) 2 1) "度")
                                         (strcat "面积:" (rtos (/ (vla-get-Area obj) 1000000) 2 2) "㎡")
        ))
      )
      ((= name "HATCH")
        (setq lst (list "【图案填充】" laynm (strcat "图案名称:" (vla-get-PatternName obj))
                                             (strcat "角度:" (rtos (toang (vla-get-PatternAngle obj) 1) 2 1))
                                             (strcat "比例:" (rtos (vla-get-PatternScale obj) 2 0))
                                             (strcat "关联:" (if (= (vla-get-AssociativeHatch obj) :vlax-false) "关闭" "打开"))
                                             (strcat "填充样式:" (nth (vla-get-HatchStyle obj) '("普通" "外部" "忽略")))
        ))
      )
      ((= name "IMAGE")
        (setq lst (list "【图像】" laynm (strcat "图像大小:" (rtos (car (dxf ent 13)) 2 0) "X" (rtos (cadr (dxf ent 13)) 2 0))))
      )
      ((= name "INSERT")
        (setq lst (list "【图块】" laynm (strcat "名称:" (dxf ent 2))
                                         (strcat "X比例:" (rtos (dxf ent 41) 2 1))
                                         (strcat "Y比例:" (rtos (dxf ent 42) 2 1))
                                         (strcat "Z比例:" (rtos (dxf ent 43) 2 1))
                                         (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
        ))
      )
      ((= name "LEADER")
        (setq lst (list "【引线】" laynm (strcat "标注样式:" (vla-get-StyleName obj))
                                         (strcat "引线类型:" (dxf (list (cons 0 "折线") (cons 1 "样条曲线")) (dxf ent 72)))
        ))
      )
      ((= name "LINE")
        (setq lst (list "【直线】" laynm (strcat "长度:" (rtos (vla-get-length obj) 2 0))
                                         (strcat "角度:" (rtos (toang (vla-get-angle obj) 1) 2 1) "度")
        ))
      )
      ((= name "LWPOLYLINE")
        (setq lst (list "【多段线】" laynm (strcat "常量宽度:" (if (dxf ent 43) (rtos (vla-get-ConstantWidth obj) 2 0) "变宽度"))
                                            (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))
                                            (strcat "面积:" (rtos (/ (vla-get-Area obj) 1000000) 2 2) "㎡")
        ))
      )
      ((= name "MLINE")
        (setq lst (list "【多线】" laynm (strcat "多线样式:" (vla-get-StyleName obj))
                                         (strcat "比例因子:" (rtos (dxf ent 40) 2 1))
                                         (strcat "对齐:" (nth (dxf ent 70) '("上" "零" "下")))
        ))
      )
      ((= name "MTEXT")
        (setq lst (list "【多行文字】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
                                             (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
                                             (strcat "样式:" (vla-get-StyleName obj))
        ))
      )
      ((or (= name "OLEFRAME") (= name "OLE2FRAME"))
        (setq lst (list "【OLE边框】" laynm (strcat "格式版本号:" (itoa (dxf ent 70)))))
      )
      ((= name "POINT")
        (setq lst (list "【点】" laynm))
      )
      ((= name "POLYLINE")
        (setq lst (list "【三维多段线】" laynm))
      )
      ((= name "RAY")
        (setq lst (list "【射线】" laynm))
      )
      ((= name "REGION")
        (setq lst (list "【面域】" laynm (strcat "格式版本号:" (itoa (dxf ent 70)))))
      )
      ((= name "SHAPE")
        (setq lst (list "【形】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
                                       (strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 1))
                                       (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
        ))
      )
      ((= name "SOLID")
        (setq lst (list "【实体】" laynm))
      )
      ((= name "SPLINE")
        (setq lst (list "【样条曲线】" laynm (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))
                                             (strcat "阶数:" (rtos (vla-get-Degree obj) 2 0))
                                             (strcat "面积:" (rtos (/ (vla-get-Area obj) 1000000) 2 2) "㎡")
        ))
      )
      ((= name "TEXT")
        (setq lst (list "【文字】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
                                         (strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 1))
                                         (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
                                         (strcat "样式:" (vla-get-StyleName obj))
                                         (strcat "对齐:" (nth (vla-get-Alignment obj) '("Left" "Center" "Right" "Aligned" "Middle" "Fit" "TopLeft" "TopCenter" "TopRight"
                                                                                        "MiddleLeft" "MiddleCenter" "MiddleRight" "BottomLeft" "BottomCenter" "BottomRight")))
        ))
      )
      ((= name "TOLERANCE")
        (setq lst (list "【公差】" laynm (strcat "标注样式:" (vla-get-StyleName obj))
                                         (strcat "文字样式:" (vla-get-TextStyle obj))
                                         (strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 1))
        ))
      )
      ((= name "TRACE")
        (setq lst (list "【宽线】" laynm))
      )
      ((= name "VERTEX")
        (setq lst (list "【顶点】" laynm (strcat "起始宽度:" (rtos (dxf ent 40) 2 0))
                                         (strcat "结束宽度:" (rtos (dxf ent 41) 2 0))
                                         (strcat "凸度:" (rtos (dxf ent 42) 2 1))
        ))
      )
      ((= name "XLINE")
        (setq lst (list "【构造线】" laynm))
      )
      (T
        (setq lst (list "【未知对象】" laynm))
      )
    )
    (setq ss (ssadd) h (/ (getvar "viewsize") 50))
    (setq ang (fx (angle (getvar "viewctr") pt)))
    (setq n (* 1.4 (1+ (/ (apply 'max (mapcar 'strlen lst)) 2.0))))
    (ssadd (add_solid pt (polar pt (car ang) (* n h)) (setq pt (polar pt (cadr ang) (+ h (* 1.8 h (length lst))))) (polar pt (car ang) (* n h))) ss)
    (setq pt (polar pt (car ang) (/ (* n h) 2)))
    (if (= (caddr ang) 0)
      (setq pt (polar pt (/ pi 2) (* 0.4 h)))
      (setq pt (polar pt (/ pi 2) (+ (* 1.4 h) (* 1.8 h (length lst)))))
    )
    (setq n -1)
    (repeat (length lst)
      (ssadd (add_text (setq pt (polar pt (+ pi (/ pi 2)) (* 1.8 h))) h 0 (nth (setq n (1+ n)) lst) "宋体" 1) ss)
    )
  )
  (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)
    (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 (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)
      )
    )
  )
  (if entold (redraw entold 4))
  (if ss (command "_.erase" ss ""))
  (setvar "osmode" oldos)
  (setvar "fillmode" oldfill)
  (setq *error* olderr)
  (princ)
)
(prompt "\n***动态查询信息info***   YAD建筑")
(princ)

aeo

牛!
"BODY"是什么东东.

xxming

面积好象算错了，还有能否显示文字信息

Qlin

(if (not (tblsearch "style" "宋体"))
(command "_.style" "宋体" "宋体" "" "" "" "" "")
)

这几行代码在我的系统上会出错，可能我用的是英文版的Win2000。

鱼雷

我也不能用

陌生人

程序很长，应该可以写出一个更短的

xjjy

没多达用处！
主要是：长度，角度精度不够，面积就更不用说了！

hyx_lyn

刚试了一下，没有测试全部的功能

感觉很好，只是有些查询结果对于我来说用处不大，只能根据个人需要来更改了

qiaqiadeng

太好了，程序功能非常强大，而且给了一个很好的方法，多谢呀

lionguns

还不错，我用的是全屏CAD，这个不用每次用命令打开属性来看了！
值得一学！

Dream.Fei

我想更多的是一种思路和方法，结果是什么并不重要。如果你要的是结果，我想，你可能并不适合在这个版块晃悠。
顶楼主一帖！

另：
这个是需要执行命令才能激发，而且在查询结束后需要再次激发。能否实现超链接一样的效果？长期驻停！

cy956

育游兄在忙什么，现在已经变成初级会员了？

ahill

好东西。。。有意思。

enixing

这东西不错，先收藏了

hyx_lyn

不错不错，这个东东确实不错，不过如能加上对属性的更改会更完美