(vl-load-com)
;;
;; Bill Kramer - PointA Wizards Lab Scroll
;; See related article for details about what is going on in this
;; code!  Function utilities are provided for adding and removing
;; specific entity objects from block definitions.
;;
;;---------------------------------------------------------------------
;; AppendBlock - Given a block name, an entity name in model space,
;; and a base point (normally location of a given insert of the block)
;; this routine will append the entity to the block definition.
;;
;; Returns object reference when successful for new item inserted into
;; the block definition.  Returns nil if the entity type is not supported.
;;
(defun AppendBlock  (BN			; block name
		     EN			; entity name to add
		     BP			; base point of insert occurance
		     /
		     acadObj		;object reference variable
		     Etype		;entity type string
		     )
  (setq	acadObj	(Get_Block_Ref_Obj BN)	;get block reference object
	EN	(entget EN)		;entity specifics
	EType	(cdr (assoc 0 EN))	;entity descriptive name
	)
  ;;
  ;; Add... method used to add objects to the block collection object.
  ;;        is specific for each type of entity you wish to support.
  ;;
  (cond
    ((= eType "LINE")			; Add a line object to the block definition
     (vla-addline
       acadObj
       (vlax-3d-point (mapcar '- (cdr (assoc 10 EN)) BP))
       (vlax-3d-point (mapcar '- (cdr (assoc 11 EN)) BP))
       )
     )
    ((= eType "CIRCLE")			; Add a circle object to the block definition
     (vla-addcircle
       acadObj
       (vlax-3d-point (mapcar '- (cdr (assoc 10 EN)) BP))
       (vlax-make-variant (cdr (assoc 40 EN)))
       )
     )
    ((= eType "ARC")			; Add an arc object to the block definition
     (vla-addarc
       acadObj
       (vlax-3d-point (mapcar '- (cdr (assoc 10 EN)) BP))
       (vlax-make-variant (cdr (assoc 40 EN)))
       (vlax-make-variant (cdr (assoc 50 EN)))
       (vlax-make-variant (cdr (assoc 51 EN)))
       )
     )
    ;; Add more objects!
    (t
     (prompt
       (strcat "\nAppend block does not know about "
	       eType
	       " objects.")))
    )
  )
;;---------------------------------------------------------------------
;; RemoveBlock - Given a block name and an entity name of an entity
;; inside the block definition, routine will remove the entity from
;; the definition.
;;
;; Entity name should be selected using something like NENTSEL to
;; obtain the nested entity name.
;;
;; No returning value of interest.
;;
(defun RemoveBlock  (BN			;block name
		     EN			;entity name of object to remove
		     /
		     acadObj		;object reference variable
		     vlEN		;entity object name
		     )
  (setq vlEN (vlax-ename->vla-object EN))
  (Vla-delete vlEN)
)
;;
;;---------------------------------------------------------------------
;; Get_Block_Ref_Obj - given block name string this function returns
;; object reference to the block table entry.  The extended Active X
;; object references are used to obtain this information.
;;
(defun Get_Block_Ref_Obj  (BN		; string name of block
			   /
			   acadObj	;AutoCAD object reference symbol
			   )
  (if (tblsearch "BLOCK" BN)		;first check if a valid block
    (setq acadObj (vlax-get-acad-object) ;acad object
	  acadObj (vla-get-documents acadObj) ;documents collection
	  acadObj (vla-item acadObj (getvar "DWGNAME"))
					;current document
	  acadObj (vla-get-blocks acadObj) ;blocks collection
	  acadObj (vla-item acadObj BN)	;block object
	  )
    )
  )
;;--------------------------------------------------------------------
;;
;; TESTING AND DEMONSTRATION OF USE FUNCTIONS
;;
;; Test 1 prep - new drawing, create some entities, define a block,
;; insert the block at numerous places.  Add another entity (LINE or
;; ARC).  Run TEST1 pick the nearest insert to the new entity,
;; then pick the new entity - it will become part of the block def.
;;
(defun C:TEST1	()
  (prompt "\nTest/demonstrate the AppendBlock function")
  (setq	EN1 (entsel "\nPick a block insert: ")
	EN1 (entget (car EN1))
	EN2 (entsel "\nPick object to add: ")
	)
  (appendblock
    (cdr (assoc 2 EN1))
    (car EN2)
    (cdr (assoc 10 EN1)))
  (command "_REGEN")			;regen display
  (princ)
  )
;;
;; Test 2 prep - run test 1.
;;
(defun C:TEST2	()
  (prompt "\nTest/demonstrate the RemoveBlock function")
  (setq	EN1
	 (nentsel
	   "\nPick entity inserted in block to remove from definition: "))
  (if EN1
    (progn
      (setq BN	(cdr (assoc 2 (entget (car (last EN1)))))
	    EN1	(car EN1))
      (removeBlock BN EN1)
      (command "_REGEN")
      )
    )
  )
;;---------------------------------------------------------------------
(prompt "\nFunction set for BlockFun has been loaded. See source for details on test runs.")
(princ)