Sub CREATEBLOCK()
 
 
 
	Dim SSetColl As AcadSelectionSets
 
	Set SSetColl = ThisDrawing.SelectionSets
 
 
 
	Dim ssetObj As AcadSelectionSet
 
	Dim mode As Integer
 
	Dim blockname As String
 
 
 
	'Create Selection Set
 
	Set ssetObj = SSetColl.Add("SS")
 
	Set ssetObj = ThisDrawing.SelectionSets.Item("SS")
 
 
 
	If ThisDrawing.ModelSpace.Count = 0 Then
 
	MsgBox "There are no objects in modelspace"
 
	Exit Sub
 
	End If
 
 
 
	'Add all entities of the modelspace to the selection set
 
	ReDim ssobjs(0 To ThisDrawing.ModelSpace.Count - 1) As AcadEntity
 
 
 
	Dim I As Integer
 
 
 
	If ThisDrawing.ModelSpace.Count = 0 Then
 
	MsgBox "There are no objects in modelspace"
 
	Exit Sub
 
	End If
 
 
 
	For I = 0 To ThisDrawing.ModelSpace.Count - 1
 
 
 
	Set ssobjs(I) = ThisDrawing.ModelSpace.Item(I)
 
 
 
	Next
 
 
 
	ssetObj.AddItems ssobjs
 
 
 
	'Specify a block name and path
 
	blockpath = "C:\"
 
	blockname = "Exportedblock.dwg"
 
 
 
	'Export all entities as one block to the specified path
 
	ThisDrawing.Wblock (blockpath & blockname), ssetObj
 
 
 
	ThisDrawing.SendCommand "Erase" & vbCr & "all" & vbCr & vbCr
 
 
 
	'Clear the selection set
 
	ssetObj.Clear
 
	ssetObj.Erase
 
	ssetObj.Delete
 
 
 
	'Test if it worked by inserting the block into the modelspace
 
	INSERTWBLOCK blockpath, blockname
 
 
 
 
 
	End Sub
 
 

Function INSERTWBLOCK(ByVal path As String, ByVal blockname As String)
 
 
 
	Dim insertionPnt(0 To 2) As Double
 
 
 
	insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
 
 
 
	Dim blockRefObj As AcadBlockReference
 
 
 
	Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, (path & blockname), 1#, 1#, 1#, 0)
 
 
 
	End Function