Topic: Merge Blocks

[cmwade77]

I am writing a routine that will merge multiple blocks into one single block. What I have so far works fairly well, except if attributes from multiple blocks have the same name, then the routine doesn't know which attribute is which once the block is merged.

I am wondering if anyone has any ideas of how to handle this?

Here is the code so far:

Code: [Select]

(defun c:MergeBlocks (/ SS Filter) 
  (setq Filter '((0 . "INSERT")))
  (while (not SS)
    (princ "\rSelect Blocks to Merge: ")
    (setq SS (ssget Filter))
  )
  (CW:MergeBlocks SS)
)

(defun CW:MergeBlocks (SS / Count SS_Length SS_Copy SS_Exploded SS_Temp SS_Temp_Length Ent Count_Temp Obj InsPt Block_Name Block_Name_Count OLD_AttReq Attributes)
  (vl-load-com)
  (vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
  ;Supporting Functions
  ;; Get Attribute Values  -  Lee Mac
  ;; Returns an association list of attributes present in the supplied block.
  ;; blk - [vla] VLA Block Reference Object
  ;; Returns: [lst] Association list of ((<tag> . <value>) ... )

  (defun LM:vl-getattributevalues ( blk )
      (mapcar '(lambda ( att ) (cons (vla-get-tagstring att) (vla-get-textstring att))) (vlax-invoke blk 'getattributes))
  )
 
  ;; Set Attribute Values  -  Lee Mac
  ;; Sets attributes with tags found in the association list to their associated values.
  ;; blk - [vla] VLA Block Reference Object
  ;; lst - [lst] Association list of ((<tag> . <value>) ... )
  ;; Returns: nil

  (defun LM:vl-setattributevalues ( blk lst / itm )
      (foreach att (vlax-invoke blk 'getattributes)
          (if (setq itm (assoc (vla-get-tagstring att) lst))
              (vla-put-textstring att (cdr itm))
          )
      )
  )
   
  ;End Suppoprting Functions
  (setq Count 0
        SS_Length (sslength SS)
        SS_Exploded (ssadd)
  )
  (while (< Count SS_Length)
    (setq Ent (ssname SS Count)
          Obj (vlax-ename->vla-object Ent)
    )
    (if Block_Name
      (setq Block_Name (strcat Block_Name "_" (vla-get-effectivename Obj)))
      (setq Block_Name (vla-get-effectivename Obj))
    )
    (if Attributes
      (setq Attributes (append (LM:vl-getattributevalues Obj) Attributes))
      (setq Attributes (LM:vl-getattributevalues Obj))
    )
    (if (not InsPt)
      (progn
        (setq InsPt (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint Obj))))
      )
    )
    (command "._explode" Ent "")
    (setq SS_Temp (ssget "_P")
          Count_Temp 0
          SS_Temp_Length (sslength SS_Temp)
    )
    (while (< Count_Temp SS_Temp_Length)
      (ssadd (ssname SS_Temp Count_Temp) SS_Exploded)
      (setq Count_Temp (+ Count_Temp 1))
    )   
    (setq Count (+ Count 1))
  )
  (setq Block_Name_Count 1)
  (while (tblsearch "BLOCK" Block_Name)
    (setq Block_Name (strcat Block_Name (rtos Block_Name_Count 2 0))
          Block_Name_Count (+ Block_Name_Count 1)
    )
  )
  (if SS_Exploded
    (progn
      (command "._-block" Block_Name InsPt SS_Exploded "")
      (setq OLD_AttReq (getvar "ATTREQ"))
      (setvar "ATTREQ" 0)
      (command "._-insert" Block_Name InsPt "" "" "")
      (setvar "ATTREQ" OLD_AttReq)
      (setq Ent (entlast)
            Obj (vlax-ename->vla-object Ent)
      )
      (princ "\nWorks!")(princ "\n")(princ Attributes)(princ "\n")
      (if Attributes
        (LM:vl-setattributevalues Obj Attributes)
      )
    )
  )
  (princ)
  (vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
)

[cmwade77]

I found a solution, all be it a little odd, but it gets the job done (I am sure there are better solutions):

Code: [Select]

(defun c:MergeBlocks (/ SS Filter) 
  (setq Filter '((0 . "INSERT")))
  (while (not SS)
    (princ "\rSelect Blocks to Merge: ")
    (setq SS (ssget Filter))
  )
  (CW:MergeBlocks SS)
)

(defun CW:MergeBlocks (SS / Count SS_Length SS_Copy SS_Exploded SS_Temp SS_Temp_Length Ent Count_Temp Obj InsPt Block_Name Block_Name_Count OLD_AttReq Attributes Handle Temp_Attributes OriginalBlockName Ent_Type)
  (vl-load-com)
  (vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
     
  ;Supporting Functions
  ;; Get Attribute Values  -  Lee Mac
  ;; Returns an association list of attributes present in the supplied block.
  ;; blk - [vla] VLA Block Reference Object
  ;; Returns: [lst] Association list of ((<tag> . <value>) ... )
 
  ;;MODIFIED BY: Chris Wade - cmwade77
  ;;Now adds text to tag string to work with mege blocks

  (defun LM:vl-getattributevalues ( blk TextToAdd )
    (mapcar '(lambda ( att ) (cons (strcat TextToAdd "_" (vla-get-tagstring att)) (vla-get-textstring att))) (vlax-invoke blk 'getattributes))   
    ;original line:
    ;(mapcar '(lambda ( att ) (cons (vla-get-tagstring att) (vla-get-textstring att))) (vlax-invoke blk 'getattributes))   
  )
 
  ;; Set Attribute Values  -  Lee Mac
  ;; Sets attributes with tags found in the association list to their associated values.
  ;; blk - [vla] VLA Block Reference Object
  ;; lst - [lst] Association list of ((<tag> . <value>) ... )
  ;; Returns: nil

  (defun LM:vl-setattributevalues ( blk lst / itm )
      (foreach att (vlax-invoke blk 'getattributes)
          (if (setq itm (assoc (vla-get-tagstring att) lst))
              (vla-put-textstring att (cdr itm))
          )
      )
  )
     
  ;End Suppoprting Functions
  (setq Count 0
        SS_Length (sslength SS)
        SS_Exploded (ssadd)
  )
  (while (< Count SS_Length)
    (setq Ent (ssname SS Count)
          Obj (vlax-ename->vla-object Ent)
          Handle (vla-get-handle Obj)
          OriginalBlockName (vla-get-effectivename Obj)
    )
    (if Block_Name
        (setq Block_Name (strcat Block_Name "_" OriginalBlockName))     
        (setq Block_Name OriginalBlockName)     
    )   
    (setq Temp_Attributes (LM:vl-getattributevalues Obj Handle))
    (if Attributes
      (setq Attributes (append Temp_Attributes Attributes))
      (setq Attributes Temp_Attributes)
    )
    (if (not InsPt)
      (progn
        (setq InsPt (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint Obj))))
      )
    )
    (command "._explode" Ent "")
    (setq SS_Temp (ssget "_P")
          Count_Temp 0
          SS_Temp_Length (sslength SS_Temp)
    )
    (while (< Count_Temp SS_Temp_Length)
      (setq Ent (ssname SS_Temp Count_Temp)
            Ent_Type (cdr (assoc 0 (entget Ent)))
            Obj (vlax-ename->vla-object Ent)
           
      )
      (if (= Ent_Type "ATTDEF")
        (progn
          (vla-put-tagstring Obj (strcat Handle "_" (vla-get-Tagstring Obj)))
        )
      )     
      (ssadd Ent SS_Exploded)
      (setq Count_Temp (+ Count_Temp 1))
    )   
    (setq Count (+ Count 1))
  )
 
  (setq Block_Name_Count 1)
  (while (tblsearch "BLOCK" Block_Name)
    (setq Block_Name (strcat Block_Name (rtos Block_Name_Count 2 0))
          Block_Name_Count (+ Block_Name_Count 1)
    )
  )
  (if SS_Exploded
    (progn
      (command "._-block" Block_Name InsPt SS_Exploded "")
      (setq OLD_AttReq (getvar "ATTREQ"))
      (setvar "ATTREQ" 0)
      (command "._-insert" Block_Name InsPt "" "" "")
      (setvar "ATTREQ" OLD_AttReq)
      (setq Ent (entlast)
            Obj (vlax-ename->vla-object Ent)
      )     
      (if Attributes
        (LM:vl-setattributevalues Obj Attributes)
      )
    )
  )
  (princ)
  (vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
)