[转贴]：MakeBlock

eachy

2. 
   
3. ; ***  MakeBlock   [Version 1.0] 4/28/95  ***
   
4. ;
   
5. ;Copyright 1995 Manu-Soft Computer Services
   
6. ;
   
7. ; ***************************************
   
8. ; ****  Author:  Owen Wengerd        ****
   
9. ; ****                               ****
   
10. ; ****  Manu-Soft Computer Services  ****
    
11. ; ****  P.O. Box 84                  ****
    
12. ; ****  Fredericksburg, OH  44627    ****
    
13. ; ****  (330) 695-5903               ****
    
14. ; ****  Compu-Serve ID:  71324,3252  ****
    
15. ; ***************************************
    
16. ;
    
17. ;
    
18. ; This program takes selected objects, defines an anonymous block,
    
19. ; then inserts the block at the original location.
    
20. 
    
21. (defun C:MAKEBLOCK
    
22. 
    
23.   (/ tmp ss ip errexit mbx BLAYER)
    
24. 
    
25. 
    
26. ;**************************************************************************
    
27.                            
    
28.                            ;Layer For Block Placement:
    
29.     (setq BLAYER nil)      ;   "XXXX" = Place on layer XXXX
    
30.                            ;   nil    = Use current layer
    
31. 
    
32. ;**************************************************************************
    
33. 
    
34. 
    
35.   (defun errexit (s)
    
36.     (princ "\nError:  ")
    
37.     (princ s)
    
38.     (restore)
    
39.   )
    
40. 
    
41.   (defun mbx ()
    
42.     (setvar "CMDECHO" (car oldvar))
    
43.     (setq *error* olderr)
    
44.     (princ)
    
45.   )
    
46. 
    
47.   ;*** Main Program ***
    
48.   (setq T (not nil))
    
49.   (setq olderr  *error*
    
50.         restore mbx
    
51.         *error* errexit
    
52.   )
    
53.   (setq oldvar
    
54.     (list
    
55.       (getvar "CMDECHO")
    
56.     )
    
57.   )
    
58.   (setvar "CMDECHO" 0)
    
59.   (terpri)
    
60.   (if BLAYER  
    
61.     (command "._LAYER"
    
62.       (if (tblsearch "LAYER" BLAYER) "_S" "_M")
    
63.       BLAYER
    
64.       ""
    
65.     )
    
66.   )
    
67.   (if
    
68.     (and
    
69.       (setq ip (getpoint "Pick Insertion Point (<0,0,0>): "))
    
70.       (setq ss (ssget))
    
71.     )
    
72.     (progn
    
73.       (entmake (list
    
74.         (cons '0 "BLOCK")
    
75.         (cons '2 "*U")
    
76.         (cons '70 1)
    
77.         (cons '10 ip)
    
78.       ))
    
79.       (setq cnt (sslength ss))
    
80.       (while (>= (setq cnt (1- cnt)) 0)
    
81.         (setq tmp (ssname ss cnt))
    
82.         (entmake (setq el (entget tmp)))
    
83.         (if (> (cdr (assoc 66 el)) 0)
    
84.           (while
    
85.             (/= "SEQEND"
    
86.               (cdr
    
87.                 (assoc 0
    
88.                   (entmake (setq el (entget (entnext (cdr (assoc -1 el))))))
    
89.                 )
    
90.               )
    
91.             )
    
92.           )
    
93.         )
    
94.         (entdel tmp)
    
95.       )
    
96.       (setq tmp (entmake (list (cons '0 "ENDBLK"))))
    
97.       (entmake (list
    
98.         (cons '0 "INSERT")
    
99.         (cons '2 tmp)
    
100.         (cons '10 ip)
     
101.       ))
     
102.     )
     
103.   )  
     
104.   (restore)
     
105. )
     

<br /> ; ***  MakeBlock   [Version 1.0] 4/28/95  ***<br /> ;<br /> ;Copyright 1995 Manu-Soft Computer Services<br /> ;<br /> ; ***************************************<br /> ; ****  Author:  Owen Wengerd        ****<br /> ; ****                               ****<br /> ; ****  Manu-Soft Computer Services  ****<br /> ; ****  P.O. Box 84                  ****<br /> ; ****  Fredericksburg, OH  44627    ****<br /> ; ****  (330) 695-5903               ****<br /> ; ****  Compu-Serve ID:  71324,3252  ****<br /> ; ***************************************<br /> ;<br /> ;<br /> ; This program takes selected objects, defines an anonymous block,<br /> ; then inserts the block at the original location.<br /> <br /> (defun C:MAKEBLOCK<br /> <br />   (/ tmp ss ip errexit mbx BLAYER)<br /> <br /> <br /> ;**************************************************************************<br />                            <br />                            ;Layer For Block Placement:<br />     (setq BLAYER nil)      ;   "XXXX" = Place on layer XXXX<br />                            ;   nil    = Use current layer<br /> <br /> ;**************************************************************************<br /> <br /> <br />   (defun errexit (s)<br />     (princ "\nError:  ")<br />     (princ s)<br />     (restore)<br />   )<br /> <br />   (defun mbx ()<br />     (setvar "CMDECHO" (car oldvar))<br />     (setq *error* olderr)<br />     (princ)<br />   )<br /> <br />   ;*** Main Program ***<br />   (setq T (not nil))<br />   (setq olderr  *error*<br />         restore mbx<br />         *error* errexit<br />   )<br />   (setq oldvar <br />     (list <br />       (getvar "CMDECHO") <br />     )<br />   )<br />   (setvar "CMDECHO" 0)<br />   (terpri)<br />   (if BLAYER  <br />     (command "._LAYER"<br />       (if (tblsearch "LAYER" BLAYER) "_S" "_M")<br />       BLAYER<br />       ""<br />     )<br />   )<br />   (if<br />     (and<br />       (setq ip (getpoint "Pick Insertion Point (<0,0,0>): "))<br />       (setq ss (ssget))<br />     )<br />     (progn<br />       (entmake (list <br />         (cons '0 "BLOCK") <br />         (cons '2 "*U") <br />         (cons '70 1) <br />         (cons '10 ip)<br />       ))<br />       (setq cnt (sslength ss))<br />       (while (>= (setq cnt (1- cnt)) 0)<br />         (setq tmp (ssname ss cnt))<br />         (entmake (setq el (entget tmp)))<br />         (if (> (cdr (assoc 66 el)) 0)<br />           (while<br />             (/= "SEQEND"<br />               (cdr<br />                 (assoc 0<br />                   (entmake (setq el (entget (entnext (cdr (assoc -1 el))))))<br />                 )<br />               )<br />             )<br />           )<br />         )<br />         (entdel tmp)<br />       ) <br />       (setq tmp (entmake (list (cons '0 "ENDBLK"))))<br />       (entmake (list <br />         (cons '0 "INSERT") <br />         (cons '2 tmp) <br />         (cons '10 ip)<br />       ))<br />     )<br />   )  <br />   (restore)<br /> )<br />

qjcpj

正在收集这方面资料，谢谢！