Here is one from my very oldies
I don't remember how it works
Code:
Option Explicit
Public Sub MakeBlockFromSSet()
Dim blkDef As AcadBlock, _
blkRef As AcadBlockReference, _
oSset As AcadSelectionSet, _
insPt As Variant, _
blkName As String, _
i As Integer
On Error GoTo Err_Control
' check if named selection set not in use
For Each oSset In ThisDrawing.SelectionSets
If oSset.Name = "$MakeBlock$" Then
oSset.Delete
Exit For
End If
Next
' create selection set
Set oSset = ThisDrawing.SelectionSets.Add("$MakeBlock$")
ThisDrawing.Utility.Prompt (vbCr & "Select objects to make block")
oSset.SelectOnScreen
' pick insertion point of block
insPt = ThisDrawing.Utility.GetPoint(, vbCr & "Pick insertion point: ")
' enter block name
blkName = InputBox(vbCr & "Enter block name: ", "Block Name")
' create block definition
Set blkDef = ThisDrawing.Blocks.Add(insPt, blkName)
' declare array of objects
ReDim objColl(0 To oSset.Count - 1) As Object
' fill array with selected objects
For i = 0 To oSset.Count - 1
Set objColl(i) = oSset.Item(i)
Next
' copy array to the newly created block definition
ThisDrawing.CopyObjects objColl, blkDef
' delete selected objects / may to uncomment this line if you need it!
' oSset.Erase
' insert new block
Set blkRef = ThisDrawing.ModelSpace.InsertBlock(insPt, blkName, 1, 1, 1, 0)
Set oSset = Nothing ' optional
Err_Control:
MsgBox Err.Description
End Sub