程序改动申请：动态查询属性

半听可乐

这个程序相信大家都不陌生，很有用，
1.最近不希望看见程序运行时那背景的一片红，请问那背景色怎么改？
2.目前只能通过空格或回车确定，怎么增加右键确定？
;---------------------------------------------------------------------------------------------------------------------
; ★DB_INFO  动态信息查询（右键确认无效）
;---------------------------------------------------------------------------------------------------------------------
(defun C:DB_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 ")
(princ)

Gu_xl

(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)
       )
    )
  )
可以使用高飞鸟的动态函数来实现显示，参见44楼:
http://bbs.mjtd.com/thread-90447-5-1.html

半听可乐

Gu_xl 发表于 2012-9-13 12:10
(defun add_solid (p1 p2 p3 p4)
    (entmakex (list (cons 0 "SOLID")
      (cons 100 "AcDbEntity")
...

链接的44楼程序我怎么使用无反应？

tianyi1230

好程序啊，感谢了，用起来很好的东西，还是感谢版主指点啊

328302216

   好长的代码

wuqiu1986

还是先来学习学习

穿靴子的猫

好程序啊，感谢楼主....

穿靴子的猫

好程序啊，感谢楼主....

yfzshe

不能计算PL的长度。。可不可以加个这功能呢

davide888

做记号