Creating new block with objects from object collection

[Thomas.Long]

I need to create a new block, one per drawing from a list of drawings, and port them into a drawing at specific locations that will be identified by code (business logic for this will be given to me later but moving the block around based on a specific insertion point should not be difficult at all)

I have a series of drawings, each with a standard block that I will know the name of, that encircle (but do not contain) a number of non standard items. I have code that can open the drawing and find all objects contained within the boundary of the block, so I now have all the items that need to go into the new block and I should be able to translate coordinates based on the bottom center of my bounding block. However, these objects are a random assortment of other objects. Drawing squares, circles, text, even other blocks. What I want is a way to copy and paste these objects into the new block reference. 3 separate times now chatgpt has given me different answers on how to do this and the methods that it's suggesting simply do not exist at all. Literally the methods it suggests do not exist on the block reference. How do I add these items onto a new block reference I'm creating? I'm sure once I do that it should be as simple as copying the block definition, pasting it into the new drawing, and then moving the insertion point to the correct location.

Sub Main()
    Dim objAcad As AcadApplication
    Dim objDoc As AcadDocument
    Dim objEnt As AcadEntity
    Dim obj As AcadEntity
    Dim objBlock As AcadBlockReference
    Dim insideObjects As Collection
    Set insideObjects = New Collection
    
    Dim blockDef As AcadBlock
    Dim blockRef As AcadBlockReference
    Dim blkName As String
    'Dim basePoint As Variant
    Dim basePoint As Point3D
    
    blkName = "Test"
    basePoint(0) = 0
    basePoint(1) = 0
    basePoint(2) = 0
    'basePoint = ThisDrawing.Utility.GetPoint(, "Specify base point for the block: ")
    'Dim ssetObj As AcadSelectionSet
    
    'For Each ssetObj In ThisDrawing.SelectionSets
        'If ssetObj.Name = "TEST_SSET2" Then
            'ssetObj.Delete
            'Exit For
        'End If
    'Next ssetObj
    
    Dim min(0 To 2) As Double
    Dim max(0 To 2) As Double
    Dim StartPoint As Variant
    Dim EndPoint As Variant
    
    Set objAcad = ThisDrawing.Application
    Set objDoc = objAcad.ActiveDocument
    
    For Each objEnt In objDoc.ModelSpace
        If objEnt.ObjectName = "AcDbBlockReference" Then
            Set objBlock = objEnt
            Set blockDef = objDoc.Blocks.Add(basePoint, blkName)
            
            If objBlock.Name = "Encasing Block name here" Then
                Call objBlock.GetBoundingBox(min, max)
                
                For Each obj In ThisDrawing.ModelSpace
                    Dim objMin(0 To 2) As Double
                    Dim objMax(0 To 2) As Double
                    
                    On Error Resume Next
                    obj.GetBoundingBox objMin, objMax
                    If Err.Number = 0 Then
                        ' Check if the object is within the block's bounding box
                        If IsWithinBoundingBox(objMin, objMax, min, max) Then
                            insideObjects.Add obj
                            'I can either add them to my collection or I can add them directly to the new block reference. Whatever is easiest.
                        End If
                    End If
                    On Error GoTo 0
                Next obj
                
                Set blockRef = objDoc.ModelSpace.InsertBlock(basePoint, blkName, 1, 1, 1, 0)
            End If
        End If
    Next objEnt

End Sub

[norman.yuan]

Firstly, you may want to make sure you describe your issue correctly in terms of terminology: entities CANNOT be added to block reference. It seems you want to create a new block definition with existing entities in the ModelSpace, and then insert a block reference in the same place as those entities are located. So, visually nothing seems changed, but you end up with a block reference replacing a group of entities - the same effect as user runs the "BLOCK" command.

If that is what your intention, the code showed here will not work as intended. I might be able to get out some code later today, showing how to grab some entities in ModelSpace and create a new block definition, and then insert its reference at the same spot. Stay tuned.

[Thomas.Long]

I only want to be able to create the block reference.  This code isn't complete yet.

I have drawing A that references drawings 1, 2, 3, 4, 5, 6. These each have the block with enclosed elements described above. The final goal is in drawing A to have it go open each drawing, create a block reference based off the entities encircled by the block, port the new block reference over to drawing A and place it in each place that it's called off (I'll get business logic for that later, haven't received it yet). So drawings 1,2,3,4,5,6, won't even be affected in the final version. This code here is a sample run just to get my block creation up and running. After that I think everything else should be fairly simple.

[norman.yuan]

OK, so let focus on creating a block definition using existing entities in current space (ModelSpace), and then inserting a reference of this newly created block definition at the place of the element entities (and these entities in the ModelSpace should be remvoed). Again, as I mentioned, the code works as if user runs the command "Block" to create a new block definition and a new reference of it. Following code does it:

Option Explicit

Public Sub CreateBlockSampe()
    
    Dim blkName As String
    blkName = "TextBlock"
    CreateNewBlock blkName, True
    
End Sub

Public Sub CreateNewBlock(blkName As String, insertReference As Boolean)

    Dim entities As Variant
    Dim basePt As Variant
    
    entities = SelectEntities()
    If VarType(entities) = vbEmpty Then
        MsgBox "Cancelled!"
        Exit Sub
    End If
    
    basePt = SelectBasePoint()
    If VarType(basePt) = vbEmpty Then
        MsgBox "Cancelled!"
        Exit Sub
    End If
    
    CreateBlockDefinition blkName, entities, basePt
    If insertReference Then
        InsertBlockReference blkName, basePt
    End If
    
End Sub

Private Function SelectEntities() As Variant

    Dim i As Integer
    Dim pt1 As Variant
    Dim pt2 As Variant
    Dim ss As AcadSelectionSet
    Dim ent As AcadEntity
    Dim entities() As AcadEntity
    
    On Error Resume Next
    
    Set ss = ThisDrawing.SelectionSets("MySelection")
    If Err.Number <> 0 Then
        Set ss = ThisDrawing.SelectionSets.Add("MySelection")
    End If
        
    Do
        pt1 = ThisDrawing.Utility.GetPoint(, vbCr & "Pick selection window corner point:")
        If Err.Number <> 0 Then
            Exit Function
        End If
        
        pt2 = ThisDrawing.Utility.GetCorner(pt1, vbCr & "Pick selection window's opposite corner:")
        If Err.Number <> 0 Then
            Exit Function
        End If
        
        ss.Clear
        ss.Select acSelectionSetWindow, pt1, pt2
        If Err.Number <> 0 Then
            Exit Function
        End If
        
        If ss.Count = 0 Then
            MsgBox "No entity found inside selection window!"
        End If
        
    Loop Until ss.Count > 0
    
    i = 0
    For Each ent In ss
        ReDim Preserve entities(i)
        Set entities(i) = ent
        i = i + 1
    Next
    ss.Delete
    
    SelectEntities = entities
    
End Function

Private Function SelectBasePoint() As Variant

    Dim pt As Variant
    
    On Error Resume Next
    
    pt = ThisDrawing.Utility.GetPoint(, vbCr & "Select basePoint:")
    If Err.Number = 0 Then
        SelectBasePoint = pt
    End If
    
End Function

Private Sub CreateBlockDefinition(blkName As String, entities As Variant, basePt As Variant)
    
    Dim blk As AcadBlock
    Dim ent As AcadEntity
    Dim i As Integer
    Dim origin(0 To 2)
    origin(0) = 0#: origin(1) = 0#: origin(2) = 0#
    
    On Error Resume Next
    
    Set blk = ThisDrawing.Blocks.Add(origin, blkName)
    If Err.Number <> 0 Then
        Set blk = ThisDrawing.Blocks(blkName)
        For Each ent In blk
            ent.Delete
        Next
    End If
    
    ThisDrawing.CopyObjects entities, blk
    blk.origin = basePt
    
    For i = 0 To UBound(entities)
        entities(i).Delete
    Next
    
End Sub

Private Sub InsertBlockReference(blkName As String, insPoint As Variant)

    ThisDrawing.ModelSpace.InsertBlock insPoint, blkName, 1#, 1#, 1#, 0#
    
End Sub

Here is a video clip showing the result of the code execution:

In this code, I ask user to pick to points to form a selection window. You, of course can still use your approach to use Bounding box to locate entities that to be converted (actually, copied) into the new block definition. The code is properly broken down to small chunks, thus should be rather easy to read/follow.

Once you have the block created in one drawing, you can use AcadDocument.CopyObjects() to copy the block reference (AcadBlockReference) to other drawings. 

 Hope this helps.