可否选择图框，自动将图框大小、比例、图号在图框上方标识出来？

ZZXXQQ

写了一个，可能不合要求。

2. ;标记图框 明经 ZZXXQQ 2014.3.8
   
3. (defun c:tt ()
   
4. (setvar "CMDECHO" 0)
   
5. (vl-load-com)
   
6. (if (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "SS-TITLE") (90 . 4) (70 . 1) (40 . 0.0)))) (progn
   
7. (setq i -1)
   
8. (repeat (sslength ss)
   
9. (setq en (ssname ss (setq i (1+ i))))
   
10. (vla-getboundingbox(vlax-ename->vla-object en) 'p1 'p2)
    
11. (setq p1 (vlax-safearray->list p1)
    
12.        p2 (vlax-safearray->list p2))
    
13. (setq ss2 (ssget "W" p1 p2 '((0 . "INSERT") (2 . "$$titleblk$$00000109"))))
    
14. (setq scl (cdr(assoc 41 (entget(ssname ss2 0)))))
    
15. (setq h (/ (- (cadr p2) (cadr p1)) scl))
    
16. (setq w (/ (- (car p2) (car p1)) scl))
    
17. (cond
    
18.   ((equal h 841 1) (setq A "A0"))
    
19.   ((equal h 594 1) (setq A "A1"))
    
20.   ((equal h 420 1) (setq A "A2"))
    
21.   ((and (equal h 297 1) (>= w 419)) (setq A "A3"))
    
22.   ((and (equal h 297 1) (>= w 209)) (setq A "A4"))
    
23.   ((and (equal h 210 1) (>= w 296)) (setq A "A4"))
    
24. )
    
25. (setq A (strcat a "(" (rtos h 2 0) "x" (rtos w 2 0) ")-1:" (rtos scl 2 0)))
    
26. (setq pt1 (polar (polar p1 (/ pi 2) (+ (* h scl) 2000)) 0 2000))
    
27. (setq pt2 (polar (polar p2 (/ pi 2) 2000) pi 2000))
    
28. (entmake
    
29. (list '(0 . "TEXT") (cons 10 pt1) '(8 . "DEFPOINTS") '(62 . 1)
    
30. '(50 . 0.0) '(41 . 0.85) '(40 . 5000.0) (cons 1 A) '(7 . "W-黑体"))
    
31. )
    
32. (entmake
    
33. (list '(0 . "TEXT") '(10 0.0 0.0 0.0) '(8 . "DEFPOINTS") '(62 . 3) '(50 . 0.0) '(41 . 0.85)
    
34. '(40 . 5000.0) (cons 1 (itoa (1+ i))) '(7 . "W-黑体") '(72 . 2) (cons 11 pt2))
    
35. )
    
36. )
    
37. ))
    
38. (setvar "CMDECHO" 0)
    
39. (princ)
    
40. )
    

;标记图框 明经 ZZXXQQ 2014.3.8<br /> (defun c:tt ()<br /> (setvar "CMDECHO" 0)<br /> (vl-load-com)<br /> (if (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "SS-TITLE") (90 . 4) (70 . 1) (40 . 0.0)))) (progn<br /> (setq i -1)<br /> (repeat (sslength ss)<br /> (setq en (ssname ss (setq i (1+ i))))<br /> (vla-getboundingbox(vlax-ename->vla-object en) 'p1 'p2)<br /> (setq p1 (vlax-safearray->list p1)<br />        p2 (vlax-safearray->list p2))<br /> (setq ss2 (ssget "W" p1 p2 '((0 . "INSERT") (2 . "$$titleblk$$00000109"))))<br /> (setq scl (cdr(assoc 41 (entget(ssname ss2 0)))))<br /> (setq h (/ (- (cadr p2) (cadr p1)) scl))<br /> (setq w (/ (- (car p2) (car p1)) scl))<br /> (cond<br />   ((equal h 841 1) (setq A "A0"))<br />   ((equal h 594 1) (setq A "A1"))<br />   ((equal h 420 1) (setq A "A2"))<br />   ((and (equal h 297 1) (>= w 419)) (setq A "A3"))<br />   ((and (equal h 297 1) (>= w 209)) (setq A "A4"))<br />   ((and (equal h 210 1) (>= w 296)) (setq A "A4"))<br /> )<br /> (setq A (strcat a "(" (rtos h 2 0) "x" (rtos w 2 0) ")-1:" (rtos scl 2 0)))<br /> (setq pt1 (polar (polar p1 (/ pi 2) (+ (* h scl) 2000)) 0 2000))<br /> (setq pt2 (polar (polar p2 (/ pi 2) 2000) pi 2000))<br /> (entmake<br /> (list '(0 . "TEXT") (cons 10 pt1) '(8 . "DEFPOINTS") '(62 . 1)<br /> '(50 . 0.0) '(41 . 0.85) '(40 . 5000.0) (cons 1 A) '(7 . "W-黑体"))<br /> )<br /> (entmake<br /> (list '(0 . "TEXT") '(10 0.0 0.0 0.0) '(8 . "DEFPOINTS") '(62 . 3) '(50 . 0.0) '(41 . 0.85)<br /> '(40 . 5000.0) (cons 1 (itoa (1+ i))) '(7 . "W-黑体") '(72 . 2) (cons 11 pt2))<br /> )<br /> )<br /> ))<br /> (setvar "CMDECHO" 0)<br /> (princ)<br /> )<br />

bai2000

不能用啊

bai2000

zhuquanmao

都是提取属性块

bai2000

老大有空修改下

myfrankie

菜卷鱼 发表于 2013-12-9 08:15
这个也没啥难度，有个简单一点的方法，就是把图框做成块，在图框的左上角添加属性文字，属性文字里填写字段 ...

有没说说具体方法 我弄不成功

sosomany

xyp1964 发表于 2013-12-8 12:25

这个使用条件与使用命令是什么？

ljfzx

zhuquanmao 发表于 2014-6-29 22:45
都是提取属性块

你好，我看了你这个提取属性块的程序，觉得挺好的，不知道能不能提供lsp呢？

hdlyt11

ZZXXQQ 发表于 2014-3-8 08:10
写了一个，可能不合要求。

选择对象:  错误 : 参数类型错误: lselsetp nil

hyp1158

zhuquanmao 发表于 2014-6-29 22:45
都是提取属性块

你用的是哪个插件工具呢？可否提供下？谢谢