物件属性动态显示

redcat

后续代码跟上-2：

1.   ;.................................................................................;
   
2. (defun _Stringify (data / typ)
   
3.   (setq data (cond
   
4.         ((eq :vlax-true data) "Yes")
   
5.         ((eq :vlax-false data) "No")
   
6.         (data)
   
7.       ) ;_ 结束cond
   
8.   ) ;_ 结束setq
   
9.   (cond ((eq 'STR (setq typ (type data)))
   
10.   data
    
11. )
    
12. ((eq 'INT typ)
    
13.   (itoa data)
    
14. )
    
15. ((eq 'REAL typ)
    
16.   (rtos data)
    
17. )
    
18. ((vl-princ-to-string data))
    
19.   ) ;_ 结束cond
    
20. ) ;_ 结束defun
    
21. ;.................................................................................;
    
22. (defun _Display (Cir Tx ss mode / cObj cSs iObj aStr iLst tStr cnt tStr)
    
23.   (setq cObj (vlax-ename->vla-object Cir)
    
24. aStr ""
    
25.   ) ;_ 结束setq
    
26.   (cond ((or (not ss) (= (sslength ss) 0)))
    
27. ((setq iObj (vl-some
    
28.         (function
    
29.    (lambda (obj)
    
30.      (if (vlax-invoke obj 'IntersectWith cObj acExtendNone)
    
31.        obj
    
32.      ) ;_ 结束if
    
33.    ) ;_ 结束lambda
    
34.         ) ;_ 结束function
    
35.         (ss->lst ss)
    
36.       ) ;_ 结束vl-some
    
37.   ) ;_ 结束setq
    
38.   (setq iLst (entget (vlax-vla-object->ename iObj)))
    
39.   (vla-put-Color cObj acRed)
    
40.   (cond ((zerop mode)
    
41.   (cond
    
42.     ((eq "INSERT" (dxf 0 iLst))
    
43.      (if (setq cSs (ssget "_X" (list (cons 0 "INSERT") (cons 2 (_GetName iObj)))))
    
44.        (setq cnt (itoa (sslength cSs)))
    
45.      ) ;_ 结束if
    
46.      (if (= 1 (dxf 66 iLst))
    
47.        (progn
    
48.          (setq aStr "\nATTRIBUTES: \n{\\fArial|b0|i0|c0|p34;")
    
49.          (foreach x (vlax-invoke iObj 'GetAttributes)
    
50.     (setq aStr (strcat aStr (vla-get-TagString x) ":  " (vla-get-TextString x) "\n"))
    
51.          ) ;_ 结束foreach
    
52.          (setq aStr (strcat aStr "}"))
    
53.        ) ;_ 结束progn
    
54.      ) ;_ 结束if
    
55.      (setq tStr (strcat "{\\C4;"
    
56.           (dxf 0 iLst)
    
57.           "}"
    
58.           "\nNAME:  "
    
59.           (_GetName iObj)
    
60.           (if cnt
    
61.      (strcat "\nINSTANCES:  " cnt)
    
62.      ""
    
63.           ) ;_ 结束if
    
64.           "\nLAYER:  "
    
65.           (dxf 8 iLst)
    
66.           "\nCOLOR:  "
    
67.           (_GetColour iLst)
    
68.           "\nLINETYPE:  "
    
69.           (vlax-get-property iObj 'Linetype)
    
70.           "\nLINEWEIGHT:  "
    
71.           (_GetLW iLst)
    
72.           "\nROTATION:  "
    
73.           (angtos (dxf 50 iLst))
    
74.           "\nSCALE:  "
    
75.           (_GetScale iLst)
    
76.           "\nDYNAMIC: "
    
77.           (_Stringify (vlax-get-property iObj 'isDynamicBlock))
    
78.           "\nXREF:  "
    
79.           (_Stringify (vlax-get-property (vla-item (vla-get-Blocks doc) (_GetName iObj)) 'ISXREF))
    
80.           aStr
    
81.          ) ;_ 结束strcat
    
82.      ) ;_ 结束setq
    
83.     )
    
84.     (t
    
85.      (setq tStr (strcat "{\\C4;" (dxf 0 iLst) "}"))
    
86.      (foreach prop '(LAYER  COLOR        LINETYPE      LINEWEIGHT    ALIGNMENT  ARCLENGTH     AREA      ATTACHMENTPOINT   CENTER        CIRCUMFERENCE
    
87.        CLOSED  CUSTOMSCALE   DEGREE      DIAMETER    DISPLAYLOCKED ELEVATION     HEIGHT      LENGTH    MEASUREMENT  OBLIQUEANGLE  RADIUS
    
88.        ROTATION  SCALEFACTOR   STYLENAME     TEXTOVERRIDE  TEXTSTRING  TOTALANGLE    WIDTH
    
89.       )
    
90.        (setq tStr (strcat tStr
    
91.      (if (and (vlax-property-available-p iObj prop) (not (eq "" (vlax-get iObj prop)))) ;_ 结束and
    
92.        (strcat "\n"
    
93.         (strcase (vl-princ-to-string prop))
    
94.         ":  "
    
95.         (cond
    
96.           ((eq prop 'COLOR)
    
97.            (_GetColour iLst)
    
98.           )
    
99.           ((vl-position prop '(DISPLAYLOCKED CLOSED))
    
100.            (_Stringify (vlax-get-property iObj prop))
     
101.           )
     
102.           ((eq prop 'ALIGNMENT)
     
103.            (cdr (assoc (vlax-get-property iObj prop) Alignment))
     
104.           )
     
105.           ((eq prop 'ATTACHMENTPOINT)
     
106.            (cdr (assoc (vlax-get-property iObj prop) Attachment))
     
107.           )
     
108.           ((or
     
109.              (and
     
110.         (eq 'MEASUREMENT prop)
     
111.         (vl-position (vla-get-ObjectName iObj) '("AcDb2LineAngularDimension" "AcDb3PointAngularDimension"))
     
112.              ) ;_ 结束and
     
113.              (and
     
114.         (eq 'TOTALANGLE prop)
     
115.         (eq "AcDbArc" (vla-get-ObjectName iObj))
     
116.              ) ;_ 结束and
     
117.              (eq 'ROTATION prop)
     
118.            ) ;_ 结束or
     
119.            (angtos (vlax-get iObj prop))
     
120.           )
     
121.           (
     
122.            (eq prop 'LINEWEIGHT)
     
123.            (_GetLW iLst)
     
124.           )
     
125.           (
     
126.            (_Stringify (vlax-get iObj prop))
     
127.           )
     
128.         ) ;_ 结束cond
     
129.        ) ;_ 结束strcat
     
130.        ""
     
131.      ) ;_ 结束if
     
132.     ) ;_ 结束strcat
     
133.        ) ;_ 结束setq
     
134.      ) ;_ 结束foreach
     
135.     )
     
136.   ) ;_ 结束cond
     
137.   (_Update
     
138.     (_PutDxf
     
139.       (_PutDxf (entget tx) 62 251)
     
140.       1
     
141.       (_Text tStr)
     
142.     ) ;_ 结束_PutDxf
     
143.   ) ;_ 结束_Update
     
144.   t
     
145.         )
     
146.   ) ;_ 结束cond
     
147. )
     
148. (t)
     
149.   ) ;_ 结束cond
     
150.   iObj
     
151. ) ;_ 结束defun

  ;.................................................................................;<br /> (defun _Stringify (data / typ)<br />   (setq data (cond<br />         ((eq :vlax-true data) "Yes")<br />         ((eq :vlax-false data) "No")<br />         (data)<br />       ) ;_ 结束cond<br />   ) ;_ 结束setq<br />   (cond ((eq 'STR (setq typ (type data)))<br />   data<br /> )<br /> ((eq 'INT typ)<br />   (itoa data)<br /> )<br /> ((eq 'REAL typ)<br />   (rtos data)<br /> )<br /> ((vl-princ-to-string data))<br />   ) ;_ 结束cond<br /> ) ;_ 结束defun<br /> ;.................................................................................;<br /> (defun _Display (Cir Tx ss mode / cObj cSs iObj aStr iLst tStr cnt tStr)<br />   (setq cObj (vlax-ename->vla-object Cir)<br /> aStr ""<br />   ) ;_ 结束setq<br />   (cond ((or (not ss) (= (sslength ss) 0)))<br /> ((setq iObj (vl-some<br />         (function<br />    (lambda (obj)<br />      (if (vlax-invoke obj 'IntersectWith cObj acExtendNone)<br />        obj<br />      ) ;_ 结束if<br />    ) ;_ 结束lambda<br />         ) ;_ 结束function<br />         (ss->lst ss)<br />       ) ;_ 结束vl-some<br />   ) ;_ 结束setq<br />   (setq iLst (entget (vlax-vla-object->ename iObj)))<br />   (vla-put-Color cObj acRed)<br />   (cond ((zerop mode)<br />   (cond<br />     ((eq "INSERT" (dxf 0 iLst))<br />      (if (setq cSs (ssget "_X" (list (cons 0 "INSERT") (cons 2 (_GetName iObj)))))<br />        (setq cnt (itoa (sslength cSs)))<br />      ) ;_ 结束if<br />      (if (= 1 (dxf 66 iLst))<br />        (progn<br />          (setq aStr "\nATTRIBUTES: \n{\\fArial|b0|i0|c0|p34;")<br />          (foreach x (vlax-invoke iObj 'GetAttributes)<br />     (setq aStr (strcat aStr (vla-get-TagString x) ":  " (vla-get-TextString x) "\n"))<br />          ) ;_ 结束foreach<br />          (setq aStr (strcat aStr "}"))<br />        ) ;_ 结束progn<br />      ) ;_ 结束if<br />      (setq tStr (strcat "{\\C4;"<br />           (dxf 0 iLst)<br />           "}"<br />           "\nNAME:  "<br />           (_GetName iObj)<br />           (if cnt<br />      (strcat "\nINSTANCES:  " cnt)<br />      ""<br />           ) ;_ 结束if<br />           "\nLAYER:  "<br />           (dxf 8 iLst)<br />           "\nCOLOR:  "<br />           (_GetColour iLst)<br />           "\nLINETYPE:  "<br />           (vlax-get-property iObj 'Linetype)<br />           "\nLINEWEIGHT:  "<br />           (_GetLW iLst)<br />           "\nROTATION:  "<br />           (angtos (dxf 50 iLst))<br />           "\nSCALE:  "<br />           (_GetScale iLst)<br />           "\nDYNAMIC: "<br />           (_Stringify (vlax-get-property iObj 'isDynamicBlock))<br />           "\nXREF:  "<br />           (_Stringify (vlax-get-property (vla-item (vla-get-Blocks doc) (_GetName iObj)) 'ISXREF))<br />           aStr<br />          ) ;_ 结束strcat<br />      ) ;_ 结束setq<br />     )<br />     (t<br />      (setq tStr (strcat "{\\C4;" (dxf 0 iLst) "}"))<br />      (foreach prop '(LAYER  COLOR        LINETYPE      LINEWEIGHT    ALIGNMENT  ARCLENGTH     AREA      ATTACHMENTPOINT   CENTER        CIRCUMFERENCE<br />        CLOSED  CUSTOMSCALE   DEGREE      DIAMETER    DISPLAYLOCKED ELEVATION     HEIGHT      LENGTH    MEASUREMENT  OBLIQUEANGLE  RADIUS<br />        ROTATION  SCALEFACTOR   STYLENAME     TEXTOVERRIDE  TEXTSTRING  TOTALANGLE    WIDTH<br />       )<br />        (setq tStr (strcat tStr<br />      (if (and (vlax-property-available-p iObj prop) (not (eq "" (vlax-get iObj prop)))) ;_ 结束and<br />        (strcat "\n"<br />         (strcase (vl-princ-to-string prop))<br />         ":  "<br />         (cond<br />           ((eq prop 'COLOR)<br />            (_GetColour iLst)<br />           )<br />           ((vl-position prop '(DISPLAYLOCKED CLOSED))<br />            (_Stringify (vlax-get-property iObj prop))<br />           )<br />           ((eq prop 'ALIGNMENT)<br />            (cdr (assoc (vlax-get-property iObj prop) Alignment))<br />           )<br />           ((eq prop 'ATTACHMENTPOINT)<br />            (cdr (assoc (vlax-get-property iObj prop) Attachment))<br />           )<br />           ((or<br />              (and<br />         (eq 'MEASUREMENT prop)<br />         (vl-position (vla-get-ObjectName iObj) '("AcDb2LineAngularDimension" "AcDb3PointAngularDimension"))<br />              ) ;_ 结束and<br />              (and<br />         (eq 'TOTALANGLE prop)<br />         (eq "AcDbArc" (vla-get-ObjectName iObj))<br />              ) ;_ 结束and<br />              (eq 'ROTATION prop)<br />            ) ;_ 结束or<br />            (angtos (vlax-get iObj prop))<br />           )<br />           (<br />            (eq prop 'LINEWEIGHT)<br />            (_GetLW iLst)<br />           )<br />           (<br />            (_Stringify (vlax-get iObj prop))<br />           )<br />         ) ;_ 结束cond<br />        ) ;_ 结束strcat<br />        ""<br />      ) ;_ 结束if<br />     ) ;_ 结束strcat<br />        ) ;_ 结束setq<br />      ) ;_ 结束foreach<br />     )<br />   ) ;_ 结束cond<br />   (_Update<br />     (_PutDxf<br />       (_PutDxf (entget tx) 62 251)<br />       1<br />       (_Text tStr)<br />     ) ;_ 结束_PutDxf<br />   ) ;_ 结束_Update<br />   t<br />         )<br />   ) ;_ 结束cond<br /> )<br /> (t)<br />   ) ;_ 结束cond<br />   iObj<br /> ) ;_ 结束defun

redcat

后续代码跟上-3（结束）：

1. ;.................................................................................;
   
2. 
   
3. (defun dxf (code lst) (cdr (assoc code lst)))
   
4. 
   
5. ;.................................................................................;
   
6. 
   
7. (defun PurgeLayer (layer)
   
8.   (if
   
9.     (not
   
10.       (vl-catch-all-error-p
    
11.   (setq layer
    
12.          (vl-catch-all-apply
    
13.      'vla-item
    
14.      (list
    
15.        (vla-get-layers
    
16.          (vla-get-ActiveDocument (vlax-get-acad-object))
    
17.        ) ;_ 结束vla-get-layers
    
18.        layer
    
19.      ) ;_ 结束list
    
20.          ) ;_ 结束vl-catch-all-apply
    
21.   ) ;_ 结束setq
    
22.       ) ;_ 结束vl-catch-all-error-p
    
23.     ) ;_ 结束not
    
24.      (vl-catch-all-apply 'vla-delete (list layer))
    
25.   ) ;_ 结束if
    
26. ) ;_ 结束defun
    
27. 
    
28. ;.................................................................................;
    
29. (defun RedrawSS  (ss mode)
    
30.   ((lambda (i)
    
31.      (while (setq e (ssname ss (setq i (1+ i))))
    
32.        (redraw e mode)
    
33.      ) ;_ 结束while
    
34.    ) ;_ 结束lambda
    
35.     -1
    
36.   )
    
37. ) ;_ 结束defun
    
38. 
    
39. ;;-------------------------------------------------------------------------------;;
    
40. ;;                           --=={  Main Function  }==--                         ;;
    
41. ;;-------------------------------------------------------------------------------;;
    
42. 
    
43. (setq cEnt  (entmakex
    
44.         (list
    
45.     (cons 0 "CIRCLE")
    
46.     (cons 8 "LMAC_DINFO")
    
47.     (cons 10 (getvar 'VIEWCTR))
    
48.     (cons 40 (setq rad (/ (getvar 'VIEWSIZE) (float DInfo:cRad))))
    
49.     (cons 62 3)
    
50.         ) ;_ 结束list
    
51.       ) ;_ 结束entmakex
    
52.       cELst (entget cEnt)
    
53. ) ;_ 结束setq
    
54. 
    
55. (setq tEnt  (entmakex
    
56.         (list (cons 0 "MTEXT")
    
57.         (cons 100 "AcDbEntity")
    
58.         (cons 100 "AcDbMText")
    
59.         (cons 8 "LMAC_DINFO")
    
60.         (cons 1 (_Text (nth DInfo:Mode ModeLst)))
    
61.         (cons 10 (getvar 'VIEWCTR))
    
62.         (cons 40 (/ (getvar 'VIEWSIZE) 60.0))
    
63.         (cons 50 0.0)
    
64.         (cons 62 71)
    
65.         (cons 71 1)
    
66.         (cons 90 3)
    
67.         (cons 63 256)
    
68.         (cons 45 1.2)
    
69.         ) ;_ 结束list
    
70.       ) ;_ 结束entmakex
    
71.       tElst (entget tEnt)
    
72.       -pi/4 (/ pi -4.)
    
73.       pi/4  (/ pi 4.)
    
74.       5pi/4 (/ (* 5 pi) 4.)
    
75. ) ;_ 结束setq
    
76. 
    
77. (setq msgLst
    
78.        '("\n[TAB Mode] [+/- Cursor Size] Move Cursor Over Objects to Retrieve Information..."
    
79.    "\n[TAB Mode] [+/- Cursor Size] Click Object to Isolate Layer, Shift+Click to Turn on All Layers..."
    
80.   )
    
81. ) ;_ 结束setq
    
82. 
    
83. (princ (setq msg (nth DInfo:Mode msgLst)))
    
84. 
    
85. (while
    
86.   (progn (setq gr   (grread 't 15 1)
    
87.          code (car gr)
    
88.          data (cadr gr)
    
89.          vs   (getvar 'VIEWSIZE)
    
90.    ) ;_ 结束setq
    
91. 
    
92.    (cond ((and (= 5 code) (listp data))
    
93.     (setq r (sqrt (* 2. rad rad)))
    
94.     (setq cEnt (_Update (setq cELst (_PutDxf (_PutDxf cELst 10 data) 40 (setq rad (/ vs (float DInfo:cRad))))) ;_ 结束setq
    
95.          ) ;_ 结束_Update
    
96.     ) ;_ 结束setq
    
97. 
    
98.     (setq tEnt (_Update
    
99.            (setq tELst (_PutDxf (_PutDxf tELst 10 (polar (polar data -pi/4 rad) 0 (/ vs 90.0))) 40 (/ vs 60.0))) ;_ 结束setq
    
100.          ) ;_ 结束_Update
     
101.     ) ;_ 结束setq
     
102. 
     
103.     (if (setq ss (ssget "_C" (polar data pi/4 r) (polar data 5pi/4 r)))
     
104.       (progn (ssdel cEnt ss)
     
105.        (ssdel tEnt ss)
     
106.        (setq Inter (_Display cEnt tEnt ss DInfo:Mode))
     
107.       ) ;_ 结束progn
     
108.     ) ;_ 结束if
     
109.     t
     
110.          )
     
111.          ((= 2 code)
     
112.     (cond
     
113.       ((vl-position data '(43 61))
     
114.        (if (> DInfo:cRad 1.0)
     
115.          (setq cEnt  (_Update (setq cELst (_PutDxf cELst 40 (setq rad (/ vs (float (setq DInfo:cRad (1- DInfo:cRad)))))))
     
116.         ) ;_ 结束_Update
     
117.          ) ;_ 结束setq
     
118. 
     
119.          (princ (strcat "\n** Maximum Cursor Size Reached **" msg))
     
120.        ) ;_ 结束if
     
121.       )
     
122.       (
     
123.        (= 45 data)
     
124.        (setq cEnt
     
125.         (_Update (setq cELst (_PutDxf cELst 40 (setq rad (/ vs (float (setq DInfo:cRad (1+ DInfo:cRad)))))))
     
126.         ) ;_ 结束_Update
     
127.        ) ;_ 结束setq
     
128.       )
     
129.       (
     
130.        (= 9 data)
     
131.        (setq DInfo:Mode (rem (1+ DInfo:Mode) 2))
     
132. 
     
133.        (setq tEnt (_Update (setq tELst (_PutDxf tELst 1 (_Text (nth DInfo:Mode ModeLst)))))) ;_ 结束setq
     
134. 
     
135.        (princ (setq msg (nth DInfo:Mode msgLst)))
     
136.       )
     
137.       ((vl-position data '(13 32))
     
138.        nil
     
139.       )
     
140.       (t)
     
141.     ) ;_ 结束cond
     
142.          )
     
143.          ((and (= 3 code) (listp data) (= 1 DInfo:Mode))
     
144.     (if (and Express (acet-sys-shift-down))
     
145.       (mapcar
     
146.         (function
     
147.           (lambda (x) (vla-put-layeron x :vlax-true))
     
148.         ) ;_ 结束function
     
149.         on
     
150.       ) ;_ 结束mapcar
     
151. 
     
152.       (if (and Inter (not (eq "LMAC_DINFO" (vla-get-layer Inter))))
     
153.         (mapcar
     
154.           (function
     
155.       (lambda  (x)
     
156.         (if (not (eq (strcase (vla-get-layer Inter)) (strcase (vla-get-name x))))
     
157.           (vla-put-layeron x :vlax-false)
     
158.         ) ;_ 结束if
     
159.       ) ;_ 结束lambda
     
160.           ) ;_ 结束function
     
161.           layers
     
162.         ) ;_ 结束mapcar
     
163.       ) ;_ 结束if
     
164.     ) ;_ 结束if
     
165.     t
     
166.          )
     
167.    ) ;_ 结束cond
     
168.   ) ;_ 结束progn
     
169. ) ;_ 结束while
     
170. (mapcar 'entdel (list tEnt cEnt))
     
171. (PurgeLayer "LMAC_DINFO")
     
172. (princ)
     
173. ) ;_ 结束defun

;.................................................................................;<br /> <br /> (defun dxf (code lst) (cdr (assoc code lst)))<br /> <br /> ;.................................................................................;<br /> <br /> (defun PurgeLayer (layer)<br />   (if<br />     (not<br />       (vl-catch-all-error-p<br />   (setq layer<br />          (vl-catch-all-apply<br />      'vla-item<br />      (list<br />        (vla-get-layers<br />          (vla-get-ActiveDocument (vlax-get-acad-object))<br />        ) ;_ 结束vla-get-layers<br />        layer<br />      ) ;_ 结束list<br />          ) ;_ 结束vl-catch-all-apply<br />   ) ;_ 结束setq<br />       ) ;_ 结束vl-catch-all-error-p<br />     ) ;_ 结束not<br />      (vl-catch-all-apply 'vla-delete (list layer))<br />   ) ;_ 结束if<br /> ) ;_ 结束defun<br /> <br /> ;.................................................................................;<br /> (defun RedrawSS  (ss mode)<br />   ((lambda (i)<br />      (while (setq e (ssname ss (setq i (1+ i))))<br />        (redraw e mode)<br />      ) ;_ 结束while<br />    ) ;_ 结束lambda<br />     -1<br />   )<br /> ) ;_ 结束defun<br /> <br /> ;;-------------------------------------------------------------------------------;;<br /> ;;                           --=={  Main Function  }==--                         ;;<br /> ;;-------------------------------------------------------------------------------;;<br /> <br /> (setq cEnt  (entmakex<br />         (list<br />     (cons 0 "CIRCLE")<br />     (cons 8 "LMAC_DINFO")<br />     (cons 10 (getvar 'VIEWCTR))<br />     (cons 40 (setq rad (/ (getvar 'VIEWSIZE) (float DInfo:cRad))))<br />     (cons 62 3)<br />         ) ;_ 结束list<br />       ) ;_ 结束entmakex<br />       cELst (entget cEnt)<br /> ) ;_ 结束setq<br /> <br /> (setq tEnt  (entmakex<br />         (list (cons 0 "MTEXT")<br />         (cons 100 "AcDbEntity")<br />         (cons 100 "AcDbMText")<br />         (cons 8 "LMAC_DINFO")<br />         (cons 1 (_Text (nth DInfo:Mode ModeLst)))<br />         (cons 10 (getvar 'VIEWCTR))<br />         (cons 40 (/ (getvar 'VIEWSIZE) 60.0))<br />         (cons 50 0.0)<br />         (cons 62 71)<br />         (cons 71 1)<br />         (cons 90 3)<br />         (cons 63 256)<br />         (cons 45 1.2)<br />         ) ;_ 结束list<br />       ) ;_ 结束entmakex<br />       tElst (entget tEnt)<br />       -pi/4 (/ pi -4.)<br />       pi/4  (/ pi 4.)<br />       5pi/4 (/ (* 5 pi) 4.)<br /> ) ;_ 结束setq<br /> <br /> (setq msgLst<br />        '("\n[TAB Mode] [+/- Cursor Size] Move Cursor Over Objects to Retrieve Information..."<br />    "\n[TAB Mode] [+/- Cursor Size] Click Object to Isolate Layer, Shift+Click to Turn on All Layers..."<br />   )<br /> ) ;_ 结束setq<br /> <br /> (princ (setq msg (nth DInfo:Mode msgLst)))<br /> <br /> (while<br />   (progn (setq gr   (grread 't 15 1)<br />          code (car gr)<br />          data (cadr gr)<br />          vs   (getvar 'VIEWSIZE)<br />    ) ;_ 结束setq<br /> <br />    (cond ((and (= 5 code) (listp data))<br />     (setq r (sqrt (* 2. rad rad)))<br />     (setq cEnt (_Update (setq cELst (_PutDxf (_PutDxf cELst 10 data) 40 (setq rad (/ vs (float DInfo:cRad))))) ;_ 结束setq<br />          ) ;_ 结束_Update<br />     ) ;_ 结束setq<br /> <br />     (setq tEnt (_Update<br />            (setq tELst (_PutDxf (_PutDxf tELst 10 (polar (polar data -pi/4 rad) 0 (/ vs 90.0))) 40 (/ vs 60.0))) ;_ 结束setq<br />          ) ;_ 结束_Update<br />     ) ;_ 结束setq<br /> <br />     (if (setq ss (ssget "_C" (polar data pi/4 r) (polar data 5pi/4 r)))<br />       (progn (ssdel cEnt ss)<br />        (ssdel tEnt ss)<br />        (setq Inter (_Display cEnt tEnt ss DInfo:Mode))<br />       ) ;_ 结束progn<br />     ) ;_ 结束if<br />     t<br />          )<br />          ((= 2 code)<br />     (cond<br />       ((vl-position data '(43 61))<br />        (if (> DInfo:cRad 1.0)<br />          (setq cEnt  (_Update (setq cELst (_PutDxf cELst 40 (setq rad (/ vs (float (setq DInfo:cRad (1- DInfo:cRad)))))))<br />         ) ;_ 结束_Update<br />          ) ;_ 结束setq<br /> <br />          (princ (strcat "\n** Maximum Cursor Size Reached **" msg))<br />        ) ;_ 结束if<br />       )<br />       (<br />        (= 45 data)<br />        (setq cEnt<br />         (_Update (setq cELst (_PutDxf cELst 40 (setq rad (/ vs (float (setq DInfo:cRad (1+ DInfo:cRad)))))))<br />         ) ;_ 结束_Update<br />        ) ;_ 结束setq<br />       )<br />       (<br />        (= 9 data)<br />        (setq DInfo:Mode (rem (1+ DInfo:Mode) 2))<br /> <br />        (setq tEnt (_Update (setq tELst (_PutDxf tELst 1 (_Text (nth DInfo:Mode ModeLst)))))) ;_ 结束setq<br /> <br />        (princ (setq msg (nth DInfo:Mode msgLst)))<br />       )<br />       ((vl-position data '(13 32))<br />        nil<br />       )<br />       (t)<br />     ) ;_ 结束cond<br />          )<br />          ((and (= 3 code) (listp data) (= 1 DInfo:Mode))<br />     (if (and Express (acet-sys-shift-down))<br />       (mapcar<br />         (function<br />           (lambda (x) (vla-put-layeron x :vlax-true))<br />         ) ;_ 结束function<br />         on<br />       ) ;_ 结束mapcar<br /> <br />       (if (and Inter (not (eq "LMAC_DINFO" (vla-get-layer Inter))))<br />         (mapcar<br />           (function<br />       (lambda  (x)<br />         (if (not (eq (strcase (vla-get-layer Inter)) (strcase (vla-get-name x))))<br />           (vla-put-layeron x :vlax-false)<br />         ) ;_ 结束if<br />       ) ;_ 结束lambda<br />           ) ;_ 结束function<br />           layers<br />         ) ;_ 结束mapcar<br />       ) ;_ 结束if<br />     ) ;_ 结束if<br />     t<br />          )<br />    ) ;_ 结束cond<br />   ) ;_ 结束progn<br /> ) ;_ 结束while<br /> (mapcar 'entdel (list tEnt cEnt))<br /> (PurgeLayer "LMAC_DINFO")<br /> (princ)<br /> ) ;_ 结束defun

redcat

个人申明：以上代码属于转载，如需改进，请注明出处

xyz2009xyz

图片看不见，好歹先看看效果再收币！

redcat

回复 xyz2009xyz 的帖子

演示在4楼怎么说没图片呢？？？

Lisper

回复 redcat 的帖子

好像是不付币就看不见图片！

display18

属实需要，程序不错

yshf

动态信息查询源程序（1）

2. 
   
3. ;;;动态信息
   
4. ;;;Copyrignt chengqiang Lin 2009 for mengyang(作者:林承强)
   
5. (defun c:vh ()
   
6. (setq AcadObject   (vlax-get-acad-object)
   
7. 
   
8. AcadDocument (vla-get-ActiveDocument Acadobject)
   
9. 
   
10. mSpace      (vla-get-ModelSpace Acaddocument)
    
11. 
    
12. )
    
13. (defun DEL_DD ()
    
14.     (if (/= SOLD_list nil)
    
15.       (progn
    
16. (if (/= ENT_SELP nil)
    
17.    (entupd ENT_SELP_1)
    
18.    (princ)
    
19. )
    
20. (entdel SOLD_list)
    
21. (entdel SOLD_list_t1)
    
22. (entdel SOLD_list_t2)
    
23. (entdel SOLD_list_t3)
    
24. (entdel SOLD_list_t4)
    
25. (entdel SOLD_list_t5)
    
26. (setq SOLD_list nil)
    
27.       )
    
28.       (princ)
    
29.     )
    
30. )
    
31. (setq *error* VHerror)
    
32. (princ "\n-->移动鼠标到任意对象可查询信息，按右键退出:")
    
33. (setq tt nil)
    
34. (while (= tt nil)
    
35.     (setq VIEW (getvar "viewsize"))
    
36.     (setq ENT_PT1 (grread t 1))
    
37.     (DEL_DD)
    
38.     (if (or (= (car ENT_PT1) 5) (= (car ENT_PT1) 12))
    
39.       (progn
    
40. (setq ENT_PT2 (car (cdr ENT_PT1)))
    
41. (setq ENT_SELP (ssget ENT_PT2))
    
42. (if (/= ENT_SELP nil)
    
43.    (progn
    
44.      (setq ENT_SELP_1 (ssname ENT_SELP 0))
    
45.      (setq pt1 ENT_PT2)
    
46.      (redraw (ssname ENT_SELP 0) 3)
    
47.      (setq ENT_S (entget (ssname ENT_SELP 0)))
    
48.      (setq entovlx (vlax-ename->vla-object (ssname ENT_SELP 0)))
    
49.      (setq ENT_MS (cdr (assoc 0 ENT_S)))
    
50.      (cond ((= ENT_MS "LINE")
    
51.      (setq t1 "【直线】")
    
52.      (setq t2 (strcat "长度:"
    
53.         (rtos (vla-get-Length entovlx)
    
54.         )
    
55.        )
    
56.      )
    
57.      (setq t3
    
58.      (strcat "角度:"
    
59.       (rtos (/ (* (angle (cdr (assoc 10 ENT_S))
    
60.            (cdr (assoc 11 ENT_S))
    
61.            )
    
62.            180
    
63.         )
    
64.         pi
    
65.       )
    
66.       )
    
67.      )
    
68.      )
    
69.      (setq t4
    
70.      (strcat
    
71.        "起点:"
    
72.        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)
    
73.         ","
    
74.         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)
    
75.         ","
    
76.         (rtos (caddr (cdr (assoc 10 ENT_S))) 2 2)
    
77.        )
    
78.      )
    
79.      )
    
80.      (setq t5
    
81.      (strcat
    
82.        "终点:"
    
83.        (strcat (rtos (car (cdr (assoc 11 ENT_S))) 2 2)
    
84.         ","
    
85.         (rtos (cadr (cdr (assoc 11 ENT_S))) 2 2)
    
86.         ","
    
87.         (rtos (caddr (cdr (assoc 11 ENT_S))) 2 2)
    
88.        )
    
89.      )
    
90.      )
    
91.     )
    
92.     ((= ENT_MS "INSERT")
    
93.      (setq t1 "【图块】")
    
94.      (setq t2 (strcat "块名:" (cdr (assoc 2 ENT_S))))
    
95.      (setq
    
96.        t3 (strcat "角度:" (angtos (cdr (assoc 50 ENT_S))))
    
97.      )
    
98.      (setq t4 (strcat "图层:" (cdr (assoc 8 ENT_S))))
    
99.      (setq t5
    
100.      (strcat
     
101.        "基点:"
     
102.        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)
     
103.         ","
     
104.         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)
     
105.         ","
     
106.         (rtos (caddr (cdr (assoc 10 ENT_S))) 2 2)
     
107.        )
     
108.      )
     
109.      )
     
110.     )
     
111.     ((= ENT_MS "TEXT")
     
112.      (setq t1 "【文字】")
     
113.      (setq t2 (strcat "内容:" (cdr (assoc 1 ENT_S))))
     
114.      (setq t3 (strcat "文字样式:" (cdr (assoc 7 ENT_S))))
     
115.      (setq t4 (strcat "文字高度:" (rtos (cdr (assoc 40 ENT_S)))))
     
116.      (setq t5
     
117.      (strcat
     
118.        "基点:"
     
119.        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)
     
120.         ","
     
121.         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)
     
122.         ","
     
123.         (rtos (caddr (cdr (assoc 10 ENT_S))) 2 2)
     
124.        )
     
125.      )
     
126.      )
     
127.     )
     
128.     ((= ENT_MS "DIMENSION")
     
129.      (setq t1 "【标注尺寸】")
     
130.      (setq t2 (strcat "内容:" (cdr (assoc 1 ENT_S))))
     
131.      (setq t3 (strcat "标注样式:" (cdr (assoc 3 ENT_S))))
     
132.      (setq t4 (strcat "图层:" (cdr (assoc 8 ENT_S))))
     
133.      (setq t5
     
134.      (strcat
     
135.        "基点:"
     
136.        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)
     
137.         ","
     
138.         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)
     
139.         ","
     
140.         (rtos (caddr (cdr (assoc 10 ENT_S))) 2 2)
     
141.        )
     
142.      )
     
143.      )
     
144.     )
     
145.     ((= ENT_MS "MTEXT")
     
146.      (setq t1 "【多行文字】")
     
147.      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))
     
148.      (setq t3 (strcat "文字样式:" (cdr (assoc 7 ENT_S))))
     
149.      (setq t4 (strcat "文字高度:" (rtos (cdr (assoc 40 ENT_S)))))
     
150.      (setq t5
     
151.      (strcat
     
152.        "基点:"
     
153.        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)
     
154.         ","
     
155.         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)
     
156.         ","
     
157.         (rtos (caddr (cdr (assoc 10 ENT_S))) 2 2)
     
158.        )
     
159.      )
     
160.      )
     
161.     )
     
162.     ((= ENT_MS "HATCH")
     
163.      (setq t1 "【边界填充】")
     
164.      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))
     
165.      (setq t3 (strcat "填充样式:" (cdr (assoc 2 ENT_S))))
     
166.      (setq t4 (strcat "填充比例:" (rtos (cdr (assoc 41 ENT_S)))))
     
167.      (setq t5
     
168.      (strcat
     
169.        "基点:"
     
170.        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)
     
171.         ","
     
172.         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)
     
173.         ","
     
174.         (rtos (caddr (cdr (assoc 10 ENT_S))) 2 2)
     
175.        )
     
176.      )
     
177.      )
     
178.     )
     
179.     ((= ENT_MS "LWPOLYLINE")
     
180.      (setq t1 "【多段线】")
     
181.      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))
     
182.      (setq t3 (strcat "长度:"
     
183.         (rtos (vla-get-Length entovlx)
     
184.         )
     
185.        )
     
186.      )
     
187.      (setq t4 (strcat "面积:" (rtos (vla-get-Area entovlx))))
     
188.      (setq t5
     
189.      (strcat
     
190.        "起点:"
     
191.        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)
     
192.         ","
     
193.         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)
     
194.         ","
     
195.         (rtos 0)
     
196.        )
     
197.      )
     
198.      )
     
199.     )
     
200.     ((= ENT_MS "CIRCLE")
     
201.      (setq t1 "【圆】")
     
202.      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))
     
203.      (setq t3 (strcat "直径:" "%%C"(rtos (* (cdr (assoc 40 ENT_S)) 2 ))))
     
204.      (setq t4 (strcat "面积:" (rtos (vla-get-Area entovlx))))
     
205.      (setq t5
     
206.      (strcat
     
207.        "圆心:"
     
208.        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)
     
209.         ","
     
210.         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)
     
211.         ","
     
212.         (rtos 0)
     
213.        )
     
214.      )
     
215.      )
     
216.     )
     
217.     ((= ENT_MS "ARC")
     
218.      (setq t1 "【圆弧】")
     
219.      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))
     
220.      (setq t3 (strcat "半径:" "R"(rtos(cdr (assoc 40 ENT_S)))))
     
221.      (setq t4 (strcat "长度:" (rtos (vla-get-ArcLength entovlx))))
     
222.      (setq t5
     
223.      (strcat
     
224.        "圆心:"
     
225.        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)
     
226.         ","
     
227.         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)
     
228.         ","
     
229.         (rtos 0)
     
230.        )
     
231.      )
     
232.      )
     
233.     )
     
234.     ((= ENT_MS "ELLIPSE")
     
235.      (setq t1 "【椭圆】")
     
236.      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))
     
237.      (setq t3 (strcat "半径比例:" (rtos (vla-get-RadiusRatio entovlx))))
     
238.      (setq t4 (strcat "面积:" (rtos (vlax-curve-getArea entovlx))))
     
239.      (setq t5
     
240.      (strcat
     
241.        "中心点:"
     
242.        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)
     
243.         ","
     
244.         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)
     
245.         ","
     
246.         (rtos 0)
     
247.        )
     
248.      )
     
249.      )
     
250.     )
     
251.     ((= ENT_MS "TOLERANCE")
     
252.      (setq t1 "【公差】")
     
253.      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))
     
254.      (setq t3 (strcat "标注样式:" (cdr (assoc 3 ENT_S))))
     
255.      (setq t4 (strcat "空间:" "模型空间"))
     
256.      (setq t5
     
257.      (strcat
     
258.        "基点:"
     
259.        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)
     
260.         ","
     
261.         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)
     
262.         ","
     
263.         (rtos 0)
     
264.        )
     
265.      )
     
266.      )
     
267.     )
     
268.     ((= ENT_MS "LEADER")
     
269.      (setq t1 "【箭头】")
     
270.      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))
     
271.      (setq t3 (strcat "标注样式:" (cdr (assoc 3 ENT_S))))
     
272.      (setq t4 (strcat "颜色:" (rtos (vla-get-DimensionLineColor entovlx))))
     
273.      (setq t5
     
274.      (strcat
     
275.        "基点:"
     
276.        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)
     
277.         ","
     
278.         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)
     
279.         ","
     
280.         (rtos 0)
     
281.        )
     
282.      )
     
283.      )
     
284.     )
     
285.     ((= ENT_MS "SPLINE")
     
286.      (setq t1 "【样条曲线】")
     
287.      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))
     
288.      (setq t3 (strcat "长度:" (rtos (vla-get-ArcLength entovlx))))
     
289.      (setq t4 (strcat "长度:"
     
290.         (rtos (vlax-curve-getEndParam entovlx)
     
291.         )
     
292.        )
     
293.      )
     
294.      (setq t5 (strcat "空间:" (cdr (assoc 410 ENT_S))))
     
295.     )
     
296.   

<br /> ;;;动态信息<br /> ;;;Copyrignt chengqiang Lin 2009 for mengyang(作者:林承强)<br /> (defun c:vh ()<br /> (setq AcadObject   (vlax-get-acad-object)<br /> <br /> AcadDocument (vla-get-ActiveDocument Acadobject)<br /> <br /> mSpace      (vla-get-ModelSpace Acaddocument)<br /> <br /> )<br /> (defun DEL_DD ()<br />     (if (/= SOLD_list nil)<br />       (progn<br /> (if (/= ENT_SELP nil)<br />    (entupd ENT_SELP_1)<br />    (princ)<br /> )<br /> (entdel SOLD_list)<br /> (entdel SOLD_list_t1)<br /> (entdel SOLD_list_t2)<br /> (entdel SOLD_list_t3)<br /> (entdel SOLD_list_t4)<br /> (entdel SOLD_list_t5)<br /> (setq SOLD_list nil)<br />       )<br />       (princ)<br />     )<br /> )<br /> (setq *error* VHerror)<br /> (princ "\n-->移动鼠标到任意对象可查询信息，按右键退出:")<br /> (setq tt nil)<br /> (while (= tt nil)<br />     (setq VIEW (getvar "viewsize"))<br />     (setq ENT_PT1 (grread t 1))<br />     (DEL_DD)<br />     (if (or (= (car ENT_PT1) 5) (= (car ENT_PT1) 12))<br />       (progn<br /> (setq ENT_PT2 (car (cdr ENT_PT1)))<br /> (setq ENT_SELP (ssget ENT_PT2))<br /> (if (/= ENT_SELP nil)<br />    (progn<br />      (setq ENT_SELP_1 (ssname ENT_SELP 0))<br />      (setq pt1 ENT_PT2)<br />      (redraw (ssname ENT_SELP 0) 3)<br />      (setq ENT_S (entget (ssname ENT_SELP 0)))<br />      (setq entovlx (vlax-ename->vla-object (ssname ENT_SELP 0)))<br />      (setq ENT_MS (cdr (assoc 0 ENT_S)))<br />      (cond ((= ENT_MS "LINE")<br />      (setq t1 "【直线】")<br />      (setq t2 (strcat "长度:"<br />         (rtos (vla-get-Length entovlx)<br />         )<br />        )<br />      )<br />      (setq t3<br />      (strcat "角度:"<br />       (rtos (/ (* (angle (cdr (assoc 10 ENT_S))<br />            (cdr (assoc 11 ENT_S))<br />            )<br />            180<br />         )<br />         pi<br />       )<br />       )<br />      )<br />      )<br />      (setq t4<br />      (strcat<br />        "起点:"<br />        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (caddr (cdr (assoc 10 ENT_S))) 2 2)<br />        )<br />      )<br />      )<br />      (setq t5<br />      (strcat<br />        "终点:"<br />        (strcat (rtos (car (cdr (assoc 11 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 11 ENT_S))) 2 2)<br />         ","<br />         (rtos (caddr (cdr (assoc 11 ENT_S))) 2 2)<br />        )<br />      )<br />      )<br />     )<br />     ((= ENT_MS "INSERT")<br />      (setq t1 "【图块】")<br />      (setq t2 (strcat "块名:" (cdr (assoc 2 ENT_S))))<br />      (setq<br />        t3 (strcat "角度:" (angtos (cdr (assoc 50 ENT_S))))<br />      )<br />      (setq t4 (strcat "图层:" (cdr (assoc 8 ENT_S))))<br />      (setq t5<br />      (strcat<br />        "基点:"<br />        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (caddr (cdr (assoc 10 ENT_S))) 2 2)<br />        )<br />      )<br />      )<br />     )<br />     ((= ENT_MS "TEXT")<br />      (setq t1 "【文字】")<br />      (setq t2 (strcat "内容:" (cdr (assoc 1 ENT_S))))<br />      (setq t3 (strcat "文字样式:" (cdr (assoc 7 ENT_S))))<br />      (setq t4 (strcat "文字高度:" (rtos (cdr (assoc 40 ENT_S)))))<br />      (setq t5<br />      (strcat<br />        "基点:"<br />        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (caddr (cdr (assoc 10 ENT_S))) 2 2)<br />        )<br />      )<br />      )<br />     )<br />     ((= ENT_MS "DIMENSION")<br />      (setq t1 "【标注尺寸】")<br />      (setq t2 (strcat "内容:" (cdr (assoc 1 ENT_S))))<br />      (setq t3 (strcat "标注样式:" (cdr (assoc 3 ENT_S))))<br />      (setq t4 (strcat "图层:" (cdr (assoc 8 ENT_S))))<br />      (setq t5<br />      (strcat<br />        "基点:"<br />        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (caddr (cdr (assoc 10 ENT_S))) 2 2)<br />        )<br />      )<br />      )<br />     )<br />     ((= ENT_MS "MTEXT")<br />      (setq t1 "【多行文字】")<br />      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))<br />      (setq t3 (strcat "文字样式:" (cdr (assoc 7 ENT_S))))<br />      (setq t4 (strcat "文字高度:" (rtos (cdr (assoc 40 ENT_S)))))<br />      (setq t5<br />      (strcat<br />        "基点:"<br />        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (caddr (cdr (assoc 10 ENT_S))) 2 2)<br />        )<br />      )<br />      )<br />     )<br />     ((= ENT_MS "HATCH")<br />      (setq t1 "【边界填充】")<br />      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))<br />      (setq t3 (strcat "填充样式:" (cdr (assoc 2 ENT_S))))<br />      (setq t4 (strcat "填充比例:" (rtos (cdr (assoc 41 ENT_S)))))<br />      (setq t5<br />      (strcat<br />        "基点:"<br />        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (caddr (cdr (assoc 10 ENT_S))) 2 2)<br />        )<br />      )<br />      )<br />     )<br />     ((= ENT_MS "LWPOLYLINE")<br />      (setq t1 "【多段线】")<br />      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))<br />      (setq t3 (strcat "长度:"<br />         (rtos (vla-get-Length entovlx)<br />         )<br />        )<br />      )<br />      (setq t4 (strcat "面积:" (rtos (vla-get-Area entovlx))))<br />      (setq t5<br />      (strcat<br />        "起点:"<br />        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos 0)<br />        )<br />      )<br />      )<br />     )<br />     ((= ENT_MS "CIRCLE")<br />      (setq t1 "【圆】")<br />      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))<br />      (setq t3 (strcat "直径:" "%%C"(rtos (* (cdr (assoc 40 ENT_S)) 2 ))))<br />      (setq t4 (strcat "面积:" (rtos (vla-get-Area entovlx))))<br />      (setq t5<br />      (strcat<br />        "圆心:"<br />        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos 0)<br />        )<br />      )<br />      )<br />     )<br />     ((= ENT_MS "ARC")<br />      (setq t1 "【圆弧】")<br />      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))<br />      (setq t3 (strcat "半径:" "R"(rtos(cdr (assoc 40 ENT_S)))))<br />      (setq t4 (strcat "长度:" (rtos (vla-get-ArcLength entovlx))))<br />      (setq t5<br />      (strcat<br />        "圆心:"<br />        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos 0)<br />        )<br />      )<br />      )<br />     )<br />     ((= ENT_MS "ELLIPSE")<br />      (setq t1 "【椭圆】")<br />      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))<br />      (setq t3 (strcat "半径比例:" (rtos (vla-get-RadiusRatio entovlx))))<br />      (setq t4 (strcat "面积:" (rtos (vlax-curve-getArea entovlx))))<br />      (setq t5<br />      (strcat<br />        "中心点:"<br />        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos 0)<br />        )<br />      )<br />      )<br />     )<br />     ((= ENT_MS "TOLERANCE")<br />      (setq t1 "【公差】")<br />      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))<br />      (setq t3 (strcat "标注样式:" (cdr (assoc 3 ENT_S))))<br />      (setq t4 (strcat "空间:" "模型空间"))<br />      (setq t5<br />      (strcat<br />        "基点:"<br />        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos 0)<br />        )<br />      )<br />      )<br />     )<br />     ((= ENT_MS "LEADER")<br />      (setq t1 "【箭头】")<br />      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))<br />      (setq t3 (strcat "标注样式:" (cdr (assoc 3 ENT_S))))<br />      (setq t4 (strcat "颜色:" (rtos (vla-get-DimensionLineColor entovlx))))<br />      (setq t5<br />      (strcat<br />        "基点:"<br />        (strcat (rtos (car (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos (cadr (cdr (assoc 10 ENT_S))) 2 2)<br />         ","<br />         (rtos 0)<br />        )<br />      )<br />      )<br />     )<br />     ((= ENT_MS "SPLINE")<br />      (setq t1 "【样条曲线】")<br />      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))<br />      (setq t3 (strcat "长度:" (rtos (vla-get-ArcLength entovlx))))<br />      (setq t4 (strcat "长度:"<br />         (rtos (vlax-curve-getEndParam entovlx)<br />         )<br />        )<br />      )<br />      (setq t5 (strcat "空间:" (cdr (assoc 410 ENT_S))))<br />     )<br />   

yshf

上接动态信息查询源程序（1）

2. 
   
3. ;;;动态信息
   
4. ;;;Copyrignt chengqiang Lin 2009 for mengyang(作者:林承强)
   
5.   ((= ENT_MS "POLYLINE")
   
6.      (setq t1 "【三维样条曲线】")
   
7.      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))
   
8.      (setq t3 (strcat "长度:" (rtos (vlax-curve-getEndParam entovlx))))
   
9.      (setq t4 (strcat "面积:" (rtos (vlax-curve-getArea entovlx))))
   
10.      (setq t5 (strcat "空间:" (cdr (assoc 410 ENT_S))))
    
11.     )
    
12.      )
    
13.      (setq TTS (max (strlen t1) (strlen t2) (strlen t3) (strlen t4) (strlen t5)))
    
14.      (setq pt2 (polar pt1 (angtof "0") (/ (* VIEW TTS )60)))
    
15.      (setq pt3 (polar pt2 (angtof "270") (/ VIEW 6)))
    
16.      (setq pt4 (polar pt3 (angtof "180") (/ (* VIEW TTS )60)))
    
17.      (setq tx0 (polar pt1 (angtof "0") (/ (/ VIEW 6) 6)))
    
18.      (setq tx1 (polar tx0 (angtof "270") (/ (/ VIEW 6) 6)))
    
19.      (setq tx2 (polar pt1 (angtof "270") (/ (/ VIEW 6) 2.5)))
    
20.      (setq tx3 (polar tx2 (angtof "270") (/ (/ VIEW 6) 6)))
    
21.      (setq tx4 (polar tx3 (angtof "270") (/ (/ VIEW 6) 6)))
    
22.      (setq tx5 (polar tx4 (angtof "270") (/ (/ VIEW 6) 6)))
    
23.      (setq txscale (/ VIEW 65))
    
24.      (setq
    
25.        SOLD_list
    
26.         (entmakex
    
27.    (list (cons 0 "SOLID")
    
28.          (cons 100 "AcDbEntity")
    
29.          (cons 62 1)
    
30.          (cons 100 "AcDbTrace")
    
31.          (cons 10 pt1)
    
32.          (cons 11 pt2)
    
33.          (cons 12 pt4)
    
34.          (cons 13 pt3)
    
35.          (cons 210 (trans (getvar "viewdir") 1 0))
    
36.    )
    
37.         )
    
38.      )
    
39.      (setq
    
40.        SOLD_list_t1
    
41.         (entmakex
    
42.    (list (cons 0 "TEXT")
    
43.          (cons 100 "AcDbEntity")
    
44.          (cons 8 "MAIN")
    
45.          (cons 100 "AcDbText")
    
46.          (cons 10 tx1)
    
47.          (cons 40 txscale)
    
48.          (cons 1 t1)
    
49.          (cons 41 0.8)
    
50.          (cons 7 "Standard")
    
51.          (cons 41 1)
    
52.          (cons 210 (trans (getvar "viewdir") 1 0))
    
53.    )
    
54.         )
    
55.      )
    
56.      (setq
    
57.        SOLD_list_t2
    
58.         (entmakex
    
59.    (list (cons 0 "TEXT")
    
60.          (cons 100 "AcDbEntity")
    
61.          (cons 8 "MAIN")
    
62.          (cons 100 "AcDbText")
    
63.          (cons 10 tx2)
    
64.          (cons 40 txscale)
    
65.          (cons 1 t2)
    
66.          (cons 41 0.8)
    
67.          (cons 7 "Standard")
    
68.          (cons 41 1)
    
69.          (cons 210 (trans (getvar "viewdir") 1 0))
    
70.    )
    
71.         )
    
72.      )
    
73.      (setq
    
74.        SOLD_list_t3
    
75.         (entmakex
    
76.    (list (cons 0 "TEXT")
    
77.          (cons 100 "AcDbEntity")
    
78.          (cons 8 "MAIN")
    
79.          (cons 100 "AcDbText")
    
80.          (cons 10 tx3)
    
81.          (cons 40 txscale)
    
82.          (cons 1 t3)
    
83.          (cons 41 0.8)
    
84.          (cons 7 "Standard")
    
85.          (cons 41 1)
    
86.          (cons 210 (trans (getvar "viewdir") 1 0))
    
87.    )
    
88.         )
    
89.      )
    
90.      (setq
    
91.        SOLD_list_t4
    
92.         (entmakex
    
93.    (list (cons 0 "TEXT")
    
94.          (cons 100 "AcDbEntity")
    
95.          (cons 8 "MAIN")
    
96.          (cons 100 "AcDbText")
    
97.          (cons 10 tx4)
    
98.          (cons 40 txscale)
    
99.          (cons 1 t4)
    
100.          (cons 41 0.8)
     
101.          (cons 7 "Standard")
     
102.          (cons 41 1)
     
103.          (cons 210 (trans (getvar "viewdir") 1 0))
     
104.    )
     
105.         )
     
106.      )
     
107.      (setq
     
108.        SOLD_list_t5
     
109.         (entmakex
     
110.    (list (cons 0 "TEXT")
     
111.          (cons 100 "AcDbEntity")
     
112.          (cons 8 "MAIN")
     
113.          (cons 100 "AcDbText")
     
114.          (cons 10 tx5)
     
115.          (cons 40 txscale)
     
116.          (cons 1 t5)
     
117.          (cons 41 0.8)
     
118.          (cons 7 "Standard")
     
119.          (cons 41 1)
     
120.          (cons 210 (trans (getvar "viewdir") 1 0))
     
121.    )
     
122.         )
     
123.      )
     
124.    )
     
125.    (progn
     
126.      (DEL_DD)
     
127.    )
     
128. )
     
129.       )
     
130.       (progn
     
131. (setq tt 1)
     
132. (DEL_DD)
     
133.       )
     
134.     )
     
135. )
     
136. )
     
137. (defun VHerror (msg1)
     
138. (setq msg1 "\n***提示:***")
     
139. (setq msg2
     
140. "\n***程序被中断***"
     
141. )
     
142. (setq tt 1)
     
143. (princ msg1)
     
144. (princ msg2)
     
145. (DEL_DD)
     
146. (setq *error* olderror)
     
147. )
     

<br /> ;;;动态信息<br /> ;;;Copyrignt chengqiang Lin 2009 for mengyang(作者:林承强)<br />   ((= ENT_MS "POLYLINE")<br />      (setq t1 "【三维样条曲线】")<br />      (setq t2 (strcat "图层:" (cdr (assoc 8 ENT_S))))<br />      (setq t3 (strcat "长度:" (rtos (vlax-curve-getEndParam entovlx))))<br />      (setq t4 (strcat "面积:" (rtos (vlax-curve-getArea entovlx))))<br />      (setq t5 (strcat "空间:" (cdr (assoc 410 ENT_S))))<br />     )<br />      )<br />      (setq TTS (max (strlen t1) (strlen t2) (strlen t3) (strlen t4) (strlen t5)))<br />      (setq pt2 (polar pt1 (angtof "0") (/ (* VIEW TTS )60)))<br />      (setq pt3 (polar pt2 (angtof "270") (/ VIEW 6)))<br />      (setq pt4 (polar pt3 (angtof "180") (/ (* VIEW TTS )60)))<br />      (setq tx0 (polar pt1 (angtof "0") (/ (/ VIEW 6) 6)))<br />      (setq tx1 (polar tx0 (angtof "270") (/ (/ VIEW 6) 6)))<br />      (setq tx2 (polar pt1 (angtof "270") (/ (/ VIEW 6) 2.5)))<br />      (setq tx3 (polar tx2 (angtof "270") (/ (/ VIEW 6) 6)))<br />      (setq tx4 (polar tx3 (angtof "270") (/ (/ VIEW 6) 6)))<br />      (setq tx5 (polar tx4 (angtof "270") (/ (/ VIEW 6) 6)))<br />      (setq txscale (/ VIEW 65))<br />      (setq<br />        SOLD_list<br />         (entmakex<br />    (list (cons 0 "SOLID")<br />          (cons 100 "AcDbEntity")<br />          (cons 62 1)<br />          (cons 100 "AcDbTrace")<br />          (cons 10 pt1)<br />          (cons 11 pt2)<br />          (cons 12 pt4)<br />          (cons 13 pt3)<br />          (cons 210 (trans (getvar "viewdir") 1 0))<br />    )<br />         )<br />      )<br />      (setq<br />        SOLD_list_t1<br />         (entmakex<br />    (list (cons 0 "TEXT")<br />          (cons 100 "AcDbEntity")<br />          (cons 8 "MAIN")<br />          (cons 100 "AcDbText")<br />          (cons 10 tx1)<br />          (cons 40 txscale)<br />          (cons 1 t1)<br />          (cons 41 0.8)<br />          (cons 7 "Standard")<br />          (cons 41 1)<br />          (cons 210 (trans (getvar "viewdir") 1 0))<br />    )<br />         )<br />      )<br />      (setq<br />        SOLD_list_t2<br />         (entmakex<br />    (list (cons 0 "TEXT")<br />          (cons 100 "AcDbEntity")<br />          (cons 8 "MAIN")<br />          (cons 100 "AcDbText")<br />          (cons 10 tx2)<br />          (cons 40 txscale)<br />          (cons 1 t2)<br />          (cons 41 0.8)<br />          (cons 7 "Standard")<br />          (cons 41 1)<br />          (cons 210 (trans (getvar "viewdir") 1 0))<br />    )<br />         )<br />      )<br />      (setq<br />        SOLD_list_t3<br />         (entmakex<br />    (list (cons 0 "TEXT")<br />          (cons 100 "AcDbEntity")<br />          (cons 8 "MAIN")<br />          (cons 100 "AcDbText")<br />          (cons 10 tx3)<br />          (cons 40 txscale)<br />          (cons 1 t3)<br />          (cons 41 0.8)<br />          (cons 7 "Standard")<br />          (cons 41 1)<br />          (cons 210 (trans (getvar "viewdir") 1 0))<br />    )<br />         )<br />      )<br />      (setq<br />        SOLD_list_t4<br />         (entmakex<br />    (list (cons 0 "TEXT")<br />          (cons 100 "AcDbEntity")<br />          (cons 8 "MAIN")<br />          (cons 100 "AcDbText")<br />          (cons 10 tx4)<br />          (cons 40 txscale)<br />          (cons 1 t4)<br />          (cons 41 0.8)<br />          (cons 7 "Standard")<br />          (cons 41 1)<br />          (cons 210 (trans (getvar "viewdir") 1 0))<br />    )<br />         )<br />      )<br />      (setq<br />        SOLD_list_t5<br />         (entmakex<br />    (list (cons 0 "TEXT")<br />          (cons 100 "AcDbEntity")<br />          (cons 8 "MAIN")<br />          (cons 100 "AcDbText")<br />          (cons 10 tx5)<br />          (cons 40 txscale)<br />          (cons 1 t5)<br />          (cons 41 0.8)<br />          (cons 7 "Standard")<br />          (cons 41 1)<br />          (cons 210 (trans (getvar "viewdir") 1 0))<br />    )<br />         )<br />      )<br />    )<br />    (progn<br />      (DEL_DD)<br />    )<br /> )<br />       )<br />       (progn<br /> (setq tt 1)<br /> (DEL_DD)<br />       )<br />     )<br /> )<br /> )<br /> (defun VHerror (msg1)<br /> (setq msg1 "\n***提示:***")<br /> (setq msg2<br /> "\n***程序被中断***"<br /> )<br /> (setq tt 1)<br /> (princ msg1)<br /> (princ msg2)<br /> (DEL_DD)<br /> (setq *error* olderror)<br /> )<br />