27 | 06 | 2017

export blocks

With the following code a block is created from all items in the modelspace. First a selection set is created and all entities are added to this selectionset. At the end the block is inserted into the modelspace.

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
The function below inserts the block created above
 
 

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
Login

Sign up now and upload your code to the website.

Help us to continue.....
Statistics
Articles View Hits
2288476
Latest Articles