Add Objects to Block

sachindkini

Program Description

The program is built around my AddObjectsToBlock subfunction, which may be used separately if necessary. The code demonstrates how to call this subfunction with the correct arguments, and, at the same time provides what is hopefully a very useful program.

The subfunction incorporates all objects contained in a supplied SelectionSet into the block definition of the specified block. Positions of the new objects in the block definition are determined relative to the supplied reference insert.

Following modification of the block definition, the active viewport will be regenerated to display changes throughout all inserts.

Program will work in all UCS/Views.

A Remove program is also included to enable the user to remove objects from block definitions.

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:AddObjectsToBlockV1-1.lsp 
下载次数:47  文件大小:9.33 KB 
下载权限: 不限 以上  [免费赚D豆]

Example of Usage

[pcode=lisp,true];;----------------=={ Add Objects to Block }==----------------;;
;;                                                            ;;
;;  Adds all objects in the provided SelectionSet to the      ;;
;;  definition of the specified block.                        ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  doc   - Document Object in which block resides.           ;;
;;  block - Entity name of reference insert                   ;;
;;  ss    - SelectionSet of objects to add to definition      ;;
;;------------------------------------------------------------;;

(defun LM:AddObjectstoBlock ( doc block ss / lst mat )
  
  (setq lst (LM:ss->vla ss)
        mat (LM:Ref->Def block)
        mat (vlax-tmatrix (append (mapcar 'append (car mat) (mapcar 'list (cadr mat))) '((0. 0. 0. 1.))))
  )
  (foreach obj lst (vla-transformby obj mat))

  (vla-CopyObjects doc (LM:SafearrayVariant vlax-vbobject lst)
    (vla-item (vla-get-Blocks doc) (cdr (assoc 2 (entget block))))
  )
  (foreach obj lst (vla-delete obj))
  (vla-regen doc acAllViewports)
)

;;-----------------=={ Remove From Block }==------------------;;
;;                                                            ;;
;;  Removes an Entity from a Block Definition                 ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ent - Entity name of Object to Delete from Block [ENAME]  ;;
;;------------------------------------------------------------;;

(defun LM:RemovefromBlock ( doc ent )
  (vla-delete (vlax-ename->vla-object ent))
  (vla-regen doc acAllViewports)
  (princ)
)

;;------------------=={ Safearray Variant }==-----------------;;
;;                                                            ;;
;;  Creates a populated Safearray Variant of a specified      ;;
;;  data type                                                 ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  datatype - variant type enum (eg vlax-vbDouble)           ;;
;;  data     - list of static type data                       ;;
;;------------------------------------------------------------;;
;;  Returns:  VLA Variant Object of type specified            ;;
;;------------------------------------------------------------;;
                        
(defun LM:SafearrayVariant ( datatype data )
  (vlax-make-variant
    (vlax-safearray-fill
      (vlax-make-safearray datatype (cons 0 (1- (length data)))) data
    )   
  )
)

;;------------=={ SelectionSet -> VLA Objects }==-------------;;
;;                                                            ;;
;;  Converts a SelectionSet to a list of VLA Objects          ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ss - Valid SelectionSet (Pickset)                         ;;
;;------------------------------------------------------------;;
;;  Returns:  List of VLA Objects, else nil                   ;;
;;------------------------------------------------------------;;

(defun LM:ss->vla ( ss / i l )
  (if ss
    (repeat (setq i (sslength ss))
      (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
    )
  )
)

;;---------------=={ Block Ref -> Block Def }==---------------;;
;;                                                            ;;
;;  Returns the Transformation Matrix and Translation Vector  ;;
;;  for transforming Block Reference Geometry to the Block    ;;
;;  Definiton.                                                ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  e - Block Reference Entity                                ;;
;;------------------------------------------------------------;;
;;  Returns:  List of 3x3 Transformation Matrix, Vector       ;;
;;------------------------------------------------------------;;

(defun LM:Ref->Def ( e / _dxf a l n )

  (defun _dxf ( x l ) (cdr (assoc x l)))

  (setq l (entget e) a (- (_dxf 50 l)) n (_dxf 210 l))
  (
    (lambda ( m )
      (list m
        (mapcar '- (_dxf 10 (tblsearch "BLOCK" (_dxf 2 l)))
          (mxv m
            (trans (_dxf 10 l) n 0)
          )
        )
      )
    )
    (mxm
      (list
        (list (/ 1. (_dxf 41 l)) 0. 0.)
        (list 0. (/ 1. (_dxf 42 l)) 0.)
        (list 0. 0. (/ 1. (_dxf 43 l)))
      )
      (mxm
        (list
          (list (cos a) (sin (- a)) 0.)
          (list (sin a) (cos a)     0.)
          (list    0.        0.     1.)
        )
        (mapcar '(lambda ( e ) (trans e n 0 t))
         '(
            (1. 0. 0.)
            (0. 1. 0.)
            (0. 0. 1.)
          )
        )
      )
    )
  )
)

;; Matrix x Vector  -  Vladimir Nesterovsky
(defun mxv ( m v )
  (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

;; Matrix x Matrix  -  Vladimir Nesterovsky
(defun mxm ( m q )
  (mapcar (function (lambda ( r ) (mxv (trp q) r))) m)
)

;; Matrix Transpose  -  Doug Wilson
(defun trp ( m )
  (apply 'mapcar (cons 'list m))
)

;;---------------------=={ Select if }==----------------------;;
;;                                                            ;;
;;  Provides continuous selection prompts until either a      ;;
;;  predicate function is validated or a keyword is supplied. ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  msg  - prompt string                                      ;;
;;  pred - optional predicate function [selection list arg]   ;;
;;  func - selection function to invoke                       ;;
;;  keyw - optional initget argument list                     ;;
;;------------------------------------------------------------;;
;;  Returns:  Entity selection list, keyword, or nil          ;;
;;------------------------------------------------------------;;

(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))  
  (while
    (progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg))
      (cond
        ( (= 7 (getvar 'ERRNO))

          (princ "\nMissed, Try again.")
        )
        ( (eq 'STR (type sel))

          nil
        )
        ( (vl-consp sel)

          (if (and pred (not (pred sel)))
            (princ "\nInvalid Object Selected.")
          )
        )
      )
    )
  )
  sel
)

;-------------------------------------------------------------;
;                   -- Test Functions --                      ;
;-------------------------------------------------------------;

(defun c:Add2Block ( / *error* _StartUndo _EndUndo acdoc ss e )

  (defun *error* ( msg )
    (if acdoc (_EndUndo acdoc))
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **")))
    (princ)
  )

  (defun _StartUndo ( doc ) (_EndUndo doc)
    (vla-StartUndoMark doc)
  )

  (defun _EndUndo ( doc )
    (if (= 8 (logand 8 (getvar 'UNDOCTL)))
      (vla-EndUndoMark doc)
    )
  )
  
  (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))

  (if
    (and (setq ss (ssget "_:L"))
      (setq e
        (LM:SelectIf "\nSelect Block to Add Objects to: "
         '(lambda ( x ) (eq "INSERT" (cdr (assoc 0 (entget (car x)))))) entsel nil
        )
      )
    )
    (progn
      (_StartUndo acdoc) (LM:AddObjectstoBlock acdoc (car e) ss) (_EndUndo acdoc)
    )
  )
  (princ)
)

;-------------------------------------------------------------;

(defun c:Remove ( / *error* _StartUndo _EndUndo acdoc e )

  (defun *error* ( msg )
    (if acdoc (_EndUndo acdoc))
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **")))
    (princ)
  )

  (defun _StartUndo ( doc ) (_EndUndo doc)
    (vla-StartUndoMark doc)
  )

  (defun _EndUndo ( doc )
    (if (= 8 (logand 8 (getvar 'UNDOCTL)))
      (vla-EndUndoMark doc)
    )
  )
  
  (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))

  (while (setq e (car (nentsel "\nSelect Object to Remove: ")))
    (_StartUndo acdoc) (LM:RemovefromBlock acdoc e) (_EndUndo acdoc)
  )
  (princ)
)

(vl-load-com) (princ)

;;------------------------------------------------------------;;
;;                         End of File                        ;;
;;------------------------------------------------------------;;[/pcode]

/db_自贡黄明儒_

thanks for sharing!!

XDSoft

XDRX_API写的一个相同功能的工具

                               
登录/注册后可看大图

[pcode=lisp,true]
(defun c:ttt( / blkname e m_blk2wcs m_wcs2blk ss)
   (if (and (setq e (car (xdrx_entsel "\n拾取块实体<退出>:")))
            (setq blkname (xdrx_getentdxf 2))   
            (setq ss ($xdlsp_ssget "\n选取添加的实体<退出>:" nil))
       )
     (progn
        (xdrx_begin)
        (setq m_blk2wcs (xdrx_matrix_block2wcs e)
              m_wcs2blk (xdrx_matrix_inverse m_blk2wcs)
        )
        (xdrx_entity_transform ss m_wcs2blk)
        (xdrx_block_append_entity blkname ss)
        (command ".erase" ss "")
        (xdrx_end)            
     )
   )
   (princ)
)

[/pcode]

ScmTools

{:soso_e179:}用XDRX_API写的代码精简

XDSoft

ScmTools 发表于 2013-5-11 16:12

                               
登录/注册后可看大图

用XDRX_API写的代码精简

所有应该做的都交给API的ARX核心去做了，LISP就轻松了。

不过还是推荐大家看看楼主的帖子源代码，XDRX_API是快，但对提高程序设计技巧没啥好处。

sachindkini

XDSoft 发表于 2013-5-11 15:50

                               
登录/注册后可看大图

XDRX_API写的一个相同功能的工具

dear sir,

nice code thx for sharing

eachy

XDSoft 发表于 2013-5-11 16:25
所有应该做的都交给API的ARX核心去做了，LISP就轻松了。

不过还是推荐大家看看楼主的帖子源代码，XDRX ...

可以用lisp仿写api提高

黄要军

ddddsssssss