[转帖]LISP匿名块程序：

lilq_78

好,顶一下

xlh0

顶！

支持！

 

highflybir

多谢指点！

龙龙仔

3. ;;change Annonymous block to normal block
4. ;;Tested in R2005
5. ;;By LUCAS
6. (defun C:AN_TO_N (/ SS)
7.   (prompt "\nSelect Annonymous block: ")
8.   (if (setq SS (ssget ":S:E" '((0 . "INSERT") (2 . "`**"))))
9.     (progn
10.       (vla-put-name
11. (vla-item (vla-get-blocks
12.     (vla-get-activedocument (vlax-get-acad-object))
13.   )
14.   (vla-get-name (vlax-ename->vla-object (ssname SS 0)))
15. )
16. "LUCAS"
17.       )
18.       (vla-auditinfo
19. (vla-get-activedocument (vlax-get-acad-object))
20. :vlax-true
21.       )
22.     )
23.     (alert "\nNot match Annonymous block!")
24.   )
25.   (princ)
26. )

;;change Annonymous block to normal block ;;Tested in R2005 ;;By LUCAS (defun C:AN_TO_N (/ SS)   (prompt "\nSelect Annonymous block: ")   (if (setq SS (ssget ":S:E" '((0 . "INSERT") (2 . "`**"))))     (progn       (vla-put-name (vla-item (vla-get-blocks     (vla-get-activedocument (vlax-get-acad-object))   )   (vla-get-name (vlax-ename->vla-object (ssname SS 0))) ) "LUCAS"       )       (vla-auditinfo (vla-get-activedocument (vlax-get-acad-object)) :vlax-true       )     )     (alert "\nNot match Annonymous block!")   )   (princ) )

highflybir

用ACTIVEX方法创建匿名图块的例子;
可以通过取得选择集合，把选择集合定义为匿名图块，然后插入进来，最后删除选择集合。

3. (defun Nblock (ss insertpt / InsPt number blocklist blk index SelectionSetObjs)
4.   (setq InsPt (vlax-3d-point insertpt));;转化为ActiveX的点
5.   (setq number (sslength ss))
6.   (setq blocklist (vla-get-blocks AcadDocument))
7.   (setq blk (vla-add blocklist InsPt "*U"));;定义匿名图块
8.   (setq SelectionSetObjs (vlax-make-safearray vlax-vbobject (cons 0 (- number 1))))
9.   (defun item (ss index)
10.     (vlax-ename->vla-object (ssname ss index))
11.   )
12.   (setq index 0)
13.   (repeat number
14.     (vlax-safearray-put-element SelectionSetObjs index (item ss index))
15.     (setq index (1+ index))
16.   );;把选择集的物体加入到匿名图块
17.   (vla-copyobjects AcadDocument SelectionSetObjs blk);;采用copybojects方式
18.   (vla-insertblock ModelSpace InsPt (vlax-get-property blk 'name) 1 1 1 0)
19. );;插入图块

(defun Nblock (ss insertpt / InsPt number blocklist blk index SelectionSetObjs)   (setq InsPt (vlax-3d-point insertpt));;转化为ActiveX的点   (setq number (sslength ss))   (setq blocklist (vla-get-blocks AcadDocument))   (setq blk (vla-add blocklist InsPt "*U"));;定义匿名图块   (setq SelectionSetObjs (vlax-make-safearray vlax-vbobject (cons 0 (- number 1))))   (defun item (ss index)     (vlax-ename->vla-object (ssname ss index))   )   (setq index 0)   (repeat number     (vlax-safearray-put-element SelectionSetObjs index (item ss index))     (setq index (1+ index))   );;把选择集的物体加入到匿名图块   (vla-copyobjects AcadDocument SelectionSetObjs blk);;采用copybojects方式   (vla-insertblock ModelSpace InsPt (vlax-get-property blk 'name) 1 1 1 0) );;插入图块

以下为测试程序

3. (defun C:test()
4.   (vl-load-com)
5.   (setq AcadObject   (vlax-get-acad-object)
6. AcadDocument (vla-get-activeDocument AcadObject)
7. ModelSpace   (vla-get-Modelspace AcadDocument)
8.   )
9.   (if (setq ss (ssget));;取得选择集
10.     (if (setq insertpt (getpoint "\n请输入插入点: "));;取得插入点
11.       (progn
12.         (nblock ss insertpt)
13. (vl-cmdf ".erase" ss "");;删除选择集
14.       )
15.     )
16.   )
17.   (princ)
18. )   

(defun C:test()   (vl-load-com)   (setq AcadObject   (vlax-get-acad-object) AcadDocument (vla-get-activeDocument AcadObject) ModelSpace   (vla-get-Modelspace AcadDocument)   )   (if (setq ss (ssget));;取得选择集     (if (setq insertpt (getpoint "\n请输入插入点: "));;取得插入点       (progn         (nblock ss insertpt) (vl-cmdf ".erase" ss "");;删除选择集       )     )   )   (princ) )   

无痕

2. ;;(mkublk ss inspt) =做无名块 ---by 狂刀.
3. (defun xt-mkUblk (ss inspt / BLKOBJ *doc I OBJS)
4.   (setq *doc   (vla-get-activedocument (vlax-get-acad-object))
5.          inspt (vlax-3d-point(trans inspt 1 0 ))
6.          i   -1
7.   )
8.   (repeat (sslength ss)
9.     (setq objs(cons (vlax-ename->vla-object (ssname ss (setq i (1+ i))))objs))
10.   )
11.   (setq blkobj(vla-add (vla-get-blocks *doc) inspt "*U"))
12.   (vlax-invoke *doc 'copyobjects objs blkobj)
13.   (mapcar 'vla-delete objs)
14.   (vla-insertblock (vla-get-ModelSpace *doc) inspt(vla-get-name blkobj) 1 1 1 0)
15.   blkobj
16. )

;;(mkublk ss inspt) =做无名块 ---by 狂刀. (defun xt-mkUblk (ss inspt / BLKOBJ *doc I OBJS)   (setq *doc   (vla-get-activedocument (vlax-get-acad-object))          inspt (vlax-3d-point(trans inspt 1 0 ))          i   -1   )   (repeat (sslength ss)     (setq objs(cons (vlax-ename->vla-object (ssname ss (setq i (1+ i))))objs))   )   (setq blkobj(vla-add (vla-get-blocks *doc) inspt "*U"))   (vlax-invoke *doc 'copyobjects objs blkobj)   (mapcar 'vla-delete objs)   (vla-insertblock (vla-get-ModelSpace *doc) inspt(vla-get-name blkobj) 1 1 1 0)   blkobj )

实例:

2. (defun c:mkublk (/ pt)
3.   (princ "\n **做无名块**")
4.   (if (setq ss (ssget))
5.     (progn
6.       (setq inspt (getpoint "\n 定义块插入点/<0,0,0>:"))
7.       (if (not inspt)(setq inspt '(0. 0. 0.)))
8.       (xt-mkUblk ss inspt)
9.     )
10.   )
11. )

(defun c:mkublk (/ pt)   (princ "\n **做无名块**")   (if (setq ss (ssget))     (progn       (setq inspt (getpoint "\n 定义块插入点/<0,0,0>:"))       (if (not inspt)(setq inspt '(0. 0. 0.)))       (xt-mkUblk ss inspt)     )   ) )

龙龙仔

highflybir & 无痕的程序對插入點不在0,0點的[屬性物件]要再處理一下才會在原位置

SunSpring

要怎么解决不在原来位置的问题啊?期待.....

tcsl9621

就是用矢量运算将块的定义点算出位置再插入到WCS下的相应点中。好像没说清楚。呵……

SunSpring

无痕发表于2007-1-4 3:54:00;;(mkublk ss inspt) =做无名块 ---by 狂刀.(defun xt-mkUblk (ss inspt / BLKOBJ *doc I OBJS)  (setq *doc   (vla-get-activedocument (vlax-get-acad-object))  &

实例:

2. (defun c:mkublk (/ pt)
3.   (princ "\n **做无名块**")
4.   (if (setq ss (ssget))
5.     (progn
6.       (setq inspt (getpoint "\n 定义块插入点/<0,0,0>:"))
7.       (if (not inspt)(setq inspt '(0. 0. 0.)))
8.       (xt-mkUblk ss inspt)
9.     )
10.   )
11. )

(defun c:mkublk (/ pt)   (princ "\n **做无名块**")   (if (setq ss (ssget))     (progn       (setq inspt (getpoint "\n 定义块插入点/<0,0,0>:"))       (if (not inspt)(setq inspt '(0. 0. 0.)))       (xt-mkUblk ss inspt)     )   ) )

2. (defun xt-mkUblk (ss inspt / BLKOBJ *doc I OBJS)
3.   (setq *doc   (vla-get-activedocument (vlax-get-acad-object))
4.          inspt (vlax-3d-point(trans inspt 1 0 ))
5.          i   -1
6.   )
7.   (repeat (sslength ss)
8.     (setq objs(cons (vlax-ename->vla-object (ssname ss (setq i (1+ i))))objs))
9.   )
10.   (mapcar '(lambda (x) (vla-move x inspt (vlax-3d-point '(0 0 0))) (vla-update x)) objs)
11.   (setq blkobj (vla-add (vla-get-blocks *doc) (vlax-3d-point '(0 0 0)) "*U"))
13.   ;;(setq blkobj(vla-add (vla-get-blocks *doc) inspt "*U"))
14.   (vlax-invoke *doc 'copyobjects objs blkobj)
15.   (mapcar 'vla-delete objs)
16.   (vla-insertblock (vla-get-ModelSpace *doc) inspt(vla-get-name blkobj) 1 1 1 0)
17.   blkobj
18. )

(defun xt-mkUblk (ss inspt / BLKOBJ *doc I OBJS)   (setq *doc   (vla-get-activedocument (vlax-get-acad-object))          inspt (vlax-3d-point(trans inspt 1 0 ))          i   -1   )   (repeat (sslength ss)     (setq objs(cons (vlax-ename->vla-object (ssname ss (setq i (1+ i))))objs))   )   (mapcar '(lambda (x) (vla-move x inspt (vlax-3d-point '(0 0 0))) (vla-update x)) objs)   (setq blkobj (vla-add (vla-get-blocks *doc) (vlax-3d-point '(0 0 0)) "*U"))   ;;(setq blkobj(vla-add (vla-get-blocks *doc) inspt "*U"))   (vlax-invoke *doc 'copyobjects objs blkobj)   (mapcar 'vla-delete objs)   (vla-insertblock (vla-get-ModelSpace *doc) inspt(vla-get-name blkobj) 1 1 1 0)   blkobj )

改为这样,就可以解决插入點不在0,0點的[屬性物件]不在原位置的问题.