[编程申请]：搜索图中的图块并统计列表（类似天正的门窗表）

autotools

搜索图中的图块并统计列表（类似天正的门窗表），用于园林的苗木表，设备专业的设备表，等等..
序号   图块名（列宽10个汉字）     数量   备注
01        荷花                        50
02        美人蕉（黄）               151
03       千屈菜                      382
  ......

f5612140

試試這個程序如何,請依各人需求自行修改

2. 
   
3. (defun c:BKNUM()
   
4. 
   
5.      (setvar "cmdecho" 0)
   
6.      (setvar "blipmode" 0)
   
7. 
   
8.      (command "erase" (ssget "X" '((8 . "BKLIST"))) "")
   
9.      (command "layer" "m" "BKTEMP" "c" 2 "BKTEMP" "")
   
10.      (command "layer" "m" "BKLIST" "c" 7 "BKLIST" "")
    
11. 
    
12.      (setq txth 50)
    
13. 
    
14.      (setq pt (getpoint "\nEnter text insert point: "))
    
15.      (command "text" pt txth 0 "Block name      dwg           Number" )
    
16.      (setq pt (mapcar '+ pt '(+0.0 -50.0 0)))
    
17.      (command "text" pt txth 0 "-----------------------------")
    
18.      (setq pt (mapcar '+ pt '(+0.0 -80.0 0)))
    
19. 
    
20.   (setq blk (assoc 2 (tblnext "block" 0)))
    
21.   (while (/= blk nil)
    
22.      (setq ss (ssget "X" (list (cons 0 "INSERT") blk)))
    
23.      (if (/= ss nil)
    
24.        (progn
    
25.          (command "chprop" ss "" "la" "BKTEMP" "")
    
26.          (setq nn (rtos (sslength ss) 2 0))
    
27.          (setq blkn (cdr blk))
    
28.          (setq txtn (strlen blkn))
    
29.          (setq ss 20)
    
30.          (repeat (- ss txtn)
    
31.             (setq blkn (strcat blkn " "))
    
32.          )
    
33.          (command "text" "ML" pt txth 0 blkn)
    
34.          (setq pt (mapcar '+ pt '(+400.0 +0.0 0)))
    
35.          (command "insert" blkn pt "" "" "")
    
36.          (setq pt (mapcar '+ pt '(+400.0 +0.0 0)))
    
37.          (command "text" "ML" pt txth 0 nn)
    
38.          (setq pt (mapcar '+ pt '(-800.0 -100.0 0)))
    
39.          (setq blk (assoc 2 (tblnext "block")))
    
40.       )
    
41.       (setq blk (assoc 2 (tblnext "block")))
    
42.     )
    
43.   )
    
44.   (prin1)
    
45.   (command "layer" "S" "0" "")
    
46. )
    
47. (prin1)
    
48. 
    

<br /> (defun c:BKNUM()<br /> <br />      (setvar "cmdecho" 0)<br />      (setvar "blipmode" 0)<br /> <br />      (command "erase" (ssget "X" '((8 . "BKLIST"))) "")<br />      (command "layer" "m" "BKTEMP" "c" 2 "BKTEMP" "")<br />      (command "layer" "m" "BKLIST" "c" 7 "BKLIST" "")<br /> <br />      (setq txth 50)<br /> <br />      (setq pt (getpoint "\nEnter text insert point: "))<br />      (command "text" pt txth 0 "Block name      dwg           Number" )<br />      (setq pt (mapcar '+ pt '(+0.0 -50.0 0)))<br />      (command "text" pt txth 0 "-----------------------------")<br />      (setq pt (mapcar '+ pt '(+0.0 -80.0 0)))<br /> <br />   (setq blk (assoc 2 (tblnext "block" 0)))<br />   (while (/= blk nil)<br />      (setq ss (ssget "X" (list (cons 0 "INSERT") blk)))<br />      (if (/= ss nil)<br />        (progn<br />          (command "chprop" ss "" "la" "BKTEMP" "")<br />          (setq nn (rtos (sslength ss) 2 0))<br />          (setq blkn (cdr blk))<br />          (setq txtn (strlen blkn))<br />          (setq ss 20)<br />          (repeat (- ss txtn)<br />             (setq blkn (strcat blkn " "))<br />          )<br />          (command "text" "ML" pt txth 0 blkn)<br />          (setq pt (mapcar '+ pt '(+400.0 +0.0 0)))<br />          (command "insert" blkn pt "" "" "")<br />          (setq pt (mapcar '+ pt '(+400.0 +0.0 0)))<br />          (command "text" "ML" pt txth 0 nn)<br />          (setq pt (mapcar '+ pt '(-800.0 -100.0 0)))<br />          (setq blk (assoc 2 (tblnext "block")))<br />       )<br />       (setq blk (assoc 2 (tblnext "block")))<br />     )<br />   )<br />   (prin1)<br />   (command "layer" "S" "0" "")<br /> )<br /> (prin1)<br /> <br />



subtlation

到这儿看看。
http://www.vba.cn/bbs/dispbbs.asp?boardID=4&ID=13393
这个程序把块的内容都可以导出去。
如果你懂一些VBA，随便改一下就可以用了。

lsjjm

TRY THIS CODE:
(defun c:test (/ b tl)
  (vl-load-com)
  (vlax-for b (vla-get-blocks
                (vla-get-ActiveDocument
                  (vlax-get-acad-object)))
    (if (= (vla-get-islayout b) :vlax-false)
      (setq tl (cons (vla-get-name b) tl))
    )
  )
  (reverse tl)
  (setq pt (getpoint "Pick Point: "))  
  (foreach item tl
    (setq ss (ssget "x" (list (cons 2 item))))
    (vl-cmdf "text" pt 0.1 0 item "")
    (vl-cmdf "text" (polar pt 0 2) 0.1 0 (sslength ss) "")
    (setq pt (polar pt (* 1.5 pi) 0.15))
  )
)

f5612140

vlisp真是簡潔有力

myfreemind

VLISP还是很强大的！

coolzhb

用我的文字修改大师V8.1，有此功能，可以自动生成文件或在图形中列表格输出！

qzaizai

啊~~太厉害了你们~

njhdb80

太厉害了你们