[求助]：如何用LISP创建无名块

yanxinbo67

在AUTOCAD使用书籍中经常看到创建无名块，但都没有说明如何创建无名块。当然有不直接的办法可以复制或剪切后粘贴为块，但
复制或剪切时没有基准点，如果用带基点复制后粘贴为块，也比较麻烦，因为粘贴后还要删除以前的。我的意思是：我用LISP实现
在图纸中画线圆等多项操作后，迅速将刚才所作的所有实体变成一个整体例如块的形式在原地方存在，最好是块的形式。我可以将刚才所作的所有实体成为一个选择集，可又怎样变成块呢

aidraft

[php]
;From Joe Burke
;make an anonymous block
;arguments: selection set, insert point, name - typically ""
;source unknown
(defun makeblock (sset baspoint name / i e en blocktype)
  (if sset
    nil
    (setq sset (ssadd))
  )
  (if (or (/= 'STR (type name)) (= "" name))
    (setq name "*A")
  )
  (if (= (substr name 1 1) "*")
    (setq blocktype 1
          name "*A"
    )
    (setq blocktype 0)
  )
  (entmake (append
             '((0 . "BLOCK"))
             (list (cons 2 name))
             (list (cons 70 blocktype))
             (list (cons 10 baspoint))
           )
  )
  (setq i -1)
  (while (setq e (ssname sset (setq i (1+ i))))
    (cond
      ((/= 1 (cdr (assoc 66 (entget e))))
       (if (entget e)
         (progn
           (entmake (entget e '("*")))
           (entdel e)
         )
       )
      )
      ((= 1 (cdr (assoc 66 (entget e))))
       (if (entget e)
         (progn
           (entmake (entget e '("*")))
           (setq en e)
           (while (/= "SEQEND" (cdr (assoc 0 (entget en))))
             (setq en (entnext en))
             (entmake (entget en '("*")))
           )
           (entdel e)
         )
       )
      )
    )
  )
  (setq name (entmake '((0 . "ENDBLK"))))
  (if name
    (progn
      (entmake (append
                 '((0 . "INSERT"))
                 (list (cons 2 name))
                 (list (cons 10 baspoint))
               )
      )
    )
  )
  (if name
    (entlast)
    nil
  )
)                                       
[/php]

shisj

如何插入和炸开无名块呢？

aidraft

；插入块：
(defun InsertBlock (InsertPt blkname / mspace)
  (vl-load-com)
  (setq        mspace (vla-get-modelspace
                 (vla-get-activedocument (vlax-get-acad-object))
               )
  )
  (vla-insertblock
    mspace
    (vlax-3d-point InsertPt)
    blkname
    1
    1
    1
    0
  )
)
；；；至于炸开，用explode或vla-explode

shisj

谢谢了，插入无名块成功，不过原理还是不太清楚，我再研究研究。

雪山飞狐(lzh)

4楼的插入无名块是用ActiveX方法，和VBA的方法一致，创建无名块用ActiveX方法要好些吧？

shisj

vla-insertblock
vla-explode
这类函数在那里可以找到帮助文件，在lisp的帮助文件中找不到该函数？

雪山飞狐(lzh)

对应VBA的对象模型的insertblock、explode方法，看看VBA的帮助

shisj

谢谢了，看来我还没有入门，还得好好学习

aidraft

;;;AX创建块，name 为"*U"则为匿名块
[php]
(defun ax:makeblock (sset        baspoint   name              /
                     blkobj        activespace              BlockDef
                     blocks        sArray           idx              doc
                     vla-objects           regen_flag errorsave
                    )
  (setq errorsave *error*)
  (defun *error* (msg)
    (setq *error* errorsave)
  )
;;;;
  (vl-load-com)
  (setq        doc    (vla-get-activedocument (vlax-get-acad-object))
        blocks (vla-get-blocks doc)
  )
  (setq        activespace
         (cond ((= (vla-get-activespace doc) 1) (vla-get-modelspace doc))
               ((= (vla-get-activespace doc) 0) (vla-get-paperspace doc))
         )
  )
  (setq        vla-objects
         '()
        idx -1
        regen_flag
         nil
        self_ref nil
  )
  (repeat (sslength sset)
    (setq vla-objects
           (append vla-objects
                   (list
                     (vlax-ename->vla-object (ssname sset (setq idx (1+ idx))))
                   )
           )
    )
  )
  (if (not (vl-catch-all-error-p
             (vl-catch-all-apply 'vla-item (list blocks name))
           )
      )
    (progn
      (initget 1 "Yes No")
      (if
        (= (getkword
             (strcat "\n" name "已定义。是否重定义？ (Yes or No) ")
           )
           "Yes"
        )
         (progn
           (if
             (apply
               'or
               (mapcar
                 '(lambda (x)
                    (and (= (vla-get-objectname x) "AcDbBlockReference")
                         (= (vla-get-name x) name)
                    )
                  )
                 vla-objects
               )
             )
              (progn (princ (strcat "\n" name "自参照。建块失败。"))
                     (exit)
              )
           )
           (setq regen_flag T)
           (setq BlockDef (vla-item blocks name))
           (vlax-for itm BlockDef
             (vla-delete itm)
           )
         )
         (progn
           (princ "\n函数被取消")
           (exit)
         )
      )
    )
  )
  (foreach itm vla-objects
    (vla-move itm
              (vlax-3d-point baspoint)
              (vlax-3d-point '(0 0 0))
    )
  )
  (setq
    blkobj (vla-add blocks (vlax-3d-point '(0 0 0)) name)
    sArray
           (vlax-safearray-fill
             (vlax-make-safearray
               vlax-vbObject
               (cons 0 (1- (length vla-objects)))
             )
             vla-objects
           )
  )
  (vla-copyobjects doc sArray blkobj)
  (mapcar 'vla-delete vla-objects)
  (if regen_flag
    (vla-regen doc acAllViewports)
  )
  (setq *error* errorsave)
  (vla-insertblock
    activespace
    (vlax-3d-point baspoint)
    (vla-get-name blkobj)
    1
    1
    1
    0
  )
)
[/php]

JOSDENNIS

４樓你的程序怎麼不舉個例，我不會ｖｌ所以不會用看不懂InsertPt 　　blkname　這兩個參數．請教．

aidraft

If you have a block call "*U1" in your drawing, then

(InsertBlock (getpoint) "*U1")

hfyqtj

看到这些东西
才知道自己太贫乏了

userzhluserzhl

10楼的这个程序在布局中的视口内运行会出错！！

taner

无名块搞不懂，不过可以生成随机名字的块。

2. 
   
3.   [FONT=courier new]
   
4. ;;; ==================================================================
   
5. ;;; 方法一:用command的方法，
   
6. (defun th-rnd-block (ss pt / blk name)
   
7.   (setq blk t)
   
8.   (while blk
   
9.     (if (null (tblobjname "block" (setq name (rtos (txt-rnd)))))
   
10.       (progn
    
11.         (command "-block" name pt ss "")
    
12.         (setq blk nil)
    
13.       )
    
14.     )
    
15.   )
    
16.   (command "-insert" name pt "" "" "")
    
17.   (princ)
    
18. )
    
19. ;;; ==================================================================
    
20. (defun txt-rnd ()                       ; 随机数种子
    
21.   (* (rem (getvar "cputicks") 1e3) 1e-3)
    
22. )
    
23. ;;; ==================================================================
    
24. ;;; 方法二：用vla方法，
    
25. (defun hao-rnd-block (ss pt / blk name)
    
26.   (setq blk t)
    
27.   (while blk
    
28.     (if (null (tblobjname "block" (setq name (rtos (txt-rnd)))))
    
29.       (progn
    
30.         (th-ss2blk ss pt name)
    
31.         (setq blk nil)
    
32.       )
    
33.     )
    
34.   )
    
35. )
    
36. ;;; ==================================================================
    
37. (defun th-ss2blk (selset inspoint blkname / array block index objlstofss ss)
    
38.   (setq block (vla-add (vla-get-blocks (thactdoc)) (vlax-3d-point inspoint)
    
39.                        blkname
    
40.               )
    
41.         objlstofss (hao-ss2objlst selset)
    
42.         index (1- (sslength selset))
    
43.         array (vlax-safearray-fill (vlax-make-safearray vlax-vbobject
    
44.                                                         (cons 0 index)
    
45.                                    ) objlstofss
    
46.               )
    
47.   )
    
48.   (vla-copyobjects (thactdoc) array block)
    
49.   (mapcar
    
50.     'vla-delete
    
51.     objlstofss
    
52.   )
    
53.   (vla-insertblock (thactsp) (vlax-3d-point inspoint) (vla-get-name block) 1
    
54.                    1 1 0
    
55.   )
    
56. )
    
57. (defun hao-ss2blk (selset inspoint blkname / array block index objlstofss)
    
58.   (setq block (vla-add (vla-get-blocks (thactdoc)) (vlax-3d-point inspoint)
    
59.                        blkname
    
60.               )
    
61.         objlstofss (hao-ss2objlst selset)
    
62.         index (1- (sslength selset))
    
63.         array (vlax-make-safearray vlax-vbobject (cons 0 index))
    
64.   )
    
65.   (foreach each objlstofss
    
66.     (vlax-safearray-put-element array index each)
    
67.     (setq index (1- index))
    
68.   )
    
69.   (vla-copyobjects (thactdoc) array block)
    
70.   (mapcar
    
71.     'vla-delete
    
72.     objlstofss
    
73.   )
    
74.   (vla-insertblock (thactsp) (vlax-3d-point inspoint) (vla-get-name block) 1
    
75.                    1 1 0
    
76.   )
    
77. )
    
78. ;;; ==================================================================
    
79. (defun thacadobj ()
    
80.   (cond
    
81.     (%$*thacadobj*$%)
    
82.     (setq %$*thacadobj*$% (vlax-get-acad-object))
    
83.   )
    
84. )
    
85. (defun thactdoc ()
    
86.   (cond
    
87.     (%$*thactdoc*$%)
    
88.     (setq %$*thactdoc*$% (vla-get-activedocument (thacadobj)))
    
89.   )
    
90. )
    
91. (defun thmodsp ()
    
92.   (cond
    
93.     (%$*thmodsp*$%)
    
94.     (setq %$*thmodsp*$% (vla-get-modelspace (thactdoc)))
    
95.   )
    
96. )
    
97. (defun thpapsp ()
    
98.   (cond
    
99.     (%$*thpapsp*$%)
    
100.     (setq %$*thpapsp*$% (vla-get-paperspace (thactdoc)))
     
101.   )
     
102. )
     
103. (defun thactsp ()
     
104.   (if (= 1 (vla-get-activespace (thactdoc)))
     
105.     (thmodsp)
     
106.     (thpapsp)
     
107.   )
     
108. )
     
109. ;;; ==================================================================
     
110. 
     
111.   [/FONT]
     

<br />   [FONT=courier new]<br /> ;;; ==================================================================<br /> ;;; 方法一:用command的方法，<br /> (defun th-rnd-block (ss pt / blk name)<br />   (setq blk t)<br />   (while blk<br />     (if (null (tblobjname "block" (setq name (rtos (txt-rnd)))))<br />       (progn<br />         (command "-block" name pt ss "")<br />         (setq blk nil)<br />       )<br />     )<br />   )<br />   (command "-insert" name pt "" "" "")<br />   (princ)<br /> )<br /> ;;; ==================================================================<br /> (defun txt-rnd ()                       ; 随机数种子<br />   (* (rem (getvar "cputicks") 1e3) 1e-3)<br /> )<br /> ;;; ==================================================================<br /> ;;; 方法二：用vla方法，<br /> (defun hao-rnd-block (ss pt / blk name)<br />   (setq blk t)<br />   (while blk<br />     (if (null (tblobjname "block" (setq name (rtos (txt-rnd)))))<br />       (progn<br />         (th-ss2blk ss pt name)<br />         (setq blk nil)<br />       )<br />     )<br />   )<br /> )<br /> ;;; ==================================================================<br /> (defun th-ss2blk (selset inspoint blkname / array block index objlstofss ss)<br />   (setq block (vla-add (vla-get-blocks (thactdoc)) (vlax-3d-point inspoint)<br />                        blkname<br />               )<br />         objlstofss (hao-ss2objlst selset)<br />         index (1- (sslength selset))<br />         array (vlax-safearray-fill (vlax-make-safearray vlax-vbobject<br />                                                         (cons 0 index)<br />                                    ) objlstofss<br />               )<br />   )<br />   (vla-copyobjects (thactdoc) array block)<br />   (mapcar<br />     'vla-delete<br />     objlstofss<br />   )<br />   (vla-insertblock (thactsp) (vlax-3d-point inspoint) (vla-get-name block) 1<br />                    1 1 0<br />   )<br /> )<br /> (defun hao-ss2blk (selset inspoint blkname / array block index objlstofss)<br />   (setq block (vla-add (vla-get-blocks (thactdoc)) (vlax-3d-point inspoint)<br />                        blkname<br />               )<br />         objlstofss (hao-ss2objlst selset)<br />         index (1- (sslength selset))<br />         array (vlax-make-safearray vlax-vbobject (cons 0 index))<br />   )<br />   (foreach each objlstofss<br />     (vlax-safearray-put-element array index each)<br />     (setq index (1- index))<br />   )<br />   (vla-copyobjects (thactdoc) array block)<br />   (mapcar<br />     'vla-delete<br />     objlstofss<br />   )<br />   (vla-insertblock (thactsp) (vlax-3d-point inspoint) (vla-get-name block) 1<br />                    1 1 0<br />   )<br /> )<br /> ;;; ==================================================================<br /> (defun thacadobj ()<br />   (cond<br />     (%$*thacadobj*$%)<br />     (setq %$*thacadobj*$% (vlax-get-acad-object))<br />   )<br /> )<br /> (defun thactdoc ()<br />   (cond<br />     (%$*thactdoc*$%)<br />     (setq %$*thactdoc*$% (vla-get-activedocument (thacadobj)))<br />   )<br /> )<br /> (defun thmodsp ()<br />   (cond<br />     (%$*thmodsp*$%)<br />     (setq %$*thmodsp*$% (vla-get-modelspace (thactdoc)))<br />   )<br /> )<br /> (defun thpapsp ()<br />   (cond<br />     (%$*thpapsp*$%)<br />     (setq %$*thpapsp*$% (vla-get-paperspace (thactdoc)))<br />   )<br /> )<br /> (defun thactsp ()<br />   (if (= 1 (vla-get-activespace (thactdoc)))<br />     (thmodsp)<br />     (thpapsp)<br />   )<br /> )<br /> ;;; ==================================================================<br /> <br />   [/FONT]<br />