[编程申请]：那位高手能给我一个做无名块的程序

panliang9

我的工作经常要将图面上的对象做成块，我通常的做法是是复制，然后右键菜单粘贴成块，将粘贴出的块放回去，将原图删掉，因为操作得很频烦，非常需要一段LISP，可以让我输入命令后就将选点，或者不用选点，直接选对象（点一律用原点），将选中的对象变成块。
谁能帮帮我。

xyp1964

所有块都必须有名！

2. [FONT=courier new];;;建立随机名图块
   
3. (defun c:test218 (/ ss1 p x2)
   
4.   (prompt "\n请选择加入块的对象: ")
   
5.   (setq ss1 (ssget))
   
6.   (princ "\n选择基点: ")
   
7.   (setq        p  (getpoint)
   
8.         x2 (rtos (* (getvar "cdate") 1000000) 2 0)
   
9.   )
   
10.   (command "_block" x2 p ss1 "")
    
11.   (command "_insert" x2 p "" "" "")
    
12.   (princ)
    
13. )
    
14. [/FONT]

[FONT=courier new];;;建立随机名图块<br /> (defun c:test218 (/ ss1 p x2)<br />   (prompt "\n请选择加入块的对象: ")<br />   (setq ss1 (ssget))<br />   (princ "\n选择基点: ")<br />   (setq        p  (getpoint)<br />         x2 (rtos (* (getvar "cdate") 1000000) 2 0)<br />   )<br />   (command "_block" x2 p ss1 "")<br />   (command "_insert" x2 p "" "" "")<br />   (princ)<br /> )<br /> [/FONT]

雨箭风刀

[PHP]
;; 用vla做任意空间内的 无名块------by alin
;; http://www.mjtd.com/bbs/dispbbs. ... ID=28461&page=1
(defun c:test  (/ ss pt doc space objs idx blkobj sArray)
  (vl-load-com)
  (setq ss (ssget)
        pt (getpoint "\nSelect insertion point:"))
  (setq doc   (vla-get-activedocument (vlax-get-acad-object))
        space (if (= (vla-get-activespace doc) 1)
                (vla-get-ModelSpace doc)
                (vla-get-PaperSpace doc))
        idx   -1)
  (repeat (sslength ss)
    (setq objs (cons (vlax-ename->vla-object (ssname ss (setq idx (1+ idx))))
                     objs))
    )
  (mapcar '(lambda (e)
             (vla-move e (vlax-3d-point pt) (vlax-3d-point '(0 0 0))))
          objs)
  (setq blkobj (vla-add (vla-get-blocks doc) (vlax-3d-point '(0 0 0)) "*U"))
  (setq sArray (vlax-safearray-fill
                 (vlax-make-safearray
                   vlax-vbObject
                   (cons 0 (1- (length objs))))
                 objs))
  (vla-copyobjects doc sArray blkobj)
  (mapcar 'vla-delete objs)
  (vla-insertblock space
                   (vlax-3d-point pt)
                   (vla-get-name blkobj)
                   1
                   1
                   1
                   0)
  (mapcar 'vlax-release-object (list doc space blkobj))
  (princ)
  )
[/PHP]
[PHP]
;| (make*blk ss pt) = 用选集造无名块------------------ok!!------lxx.2004.2
参数: ss = 要加入无名块的实体选集.
      pt = 块定义点.
返回: 成功返回新定义的块表. 失败返回 nil.
测试: (make*blk (ssget) (setq pt (getpoint)))
|;
(defun make*blk (ss pt / i ent blk)
  ;;造快表开始标志实体.
  (entmake (list'(0 . "BLOCK");实体名.
                '(2 . "*U");无名块名称.
                '(70 . 1)  ;无名块标志.
                (cons 10 pt);插入点.可用(getpoint)另外定义.
            )
  )
  (setq i -1)
  (repeat (sslength ss)
    (setq ent (ssname ss (setq i (1+ i))))
    (entmake (entget ent))
    (entdel ent)
  )
  ;;造块表结束标志实体.
  (setq blk (entmake '((0 . "ENDBLK"))));;返回以上块定义.
  ;(vl-cmdf ".erase" ss "")
  (if blk  ;如果造块成功.插入一个实例.
    (entmake (list (cons 0 "INSERT")  ;生成块实体(和块定义是不同的).
                   (cons 2 blk)       ;组码2引用块定义.
                   (cons 10 pt)       ;块插入点,按定义点.
             )
    )
  )
  (princ "\n已经做成无名块:")(princ blk)
)

;;造无名块命令:
(defun c:*blk ()
  (princ "\n选择做无名块的实体:")
  (make*blk (ssget)(getpoint "\n定义插入点:"))
  (princ)
)
[/PHP]

panliang9

非常感谢你们的程序，我就知道这里能把问题解决。
感谢斑主和雨箭风刀两位高手，我们的身边如果有你们这样的高手，能够随时请教，那就太好了，可惜没有。很多时候只能耐着性子，皱着眉头一笔笔的画，真是够烦的。

AyungerStudio

;;;********************************
;;; No.22-1 生成无名/有名图块 函数
;;;********************************
(defun MakeBlock(strBlockName xSS insPt / count entlist ent Blk retBlk)
        (setq ss xSS)
        (if (= strBlockName "")
          (entmake (list (cons 0 "BLOCK") (cons 2 "*U") (cons 70 1) (cons 10 insPt)));无名块.
                (entmake (list (cons 0 "BLOCK") (cons 2 strBlockName) (cons 70 0) (cons 10 insPt)));有名块.
        );endif
  (setq count 0)
  (repeat (sslength ss)
    (setq entlist(entget(setq ent(ssname ss  count))))
    (setq count (1+ count))
    (entmake entlist)
  );end_repeat
  (setq count 0)
  (repeat(sslength ss)
    (setq ent(ssname ss count))
    (setq count (1+ count))
    (entdel ent)
  );end_repeat
        (setq Blk(entmake '((0 . "ENDBLK"))))
        (if (princ Blk)
                (entmake (list (cons 0  "INSERT") (cons 2 Blk) (cons 10 insPt)))
        );end_if
  (setq retBlk Blk)
);end_defun