Tuesday, June 28, 2005
Extracting All Blocks In a Drawing
Platform: AutoCAD 2004-2006
Download: Extract All.zip
Well here I am after a VERY long break! I promise to be adding a few new articles in the near future, including some for Inventor.
A while ago I had the need to individually wblock out every block in a very large file, around 1500 blocks...The prospect of having to find and export every one by hand was not very appealing so I decided to whip up the bit of code below. Be sure to add all of this into a new module:
Public Function ExtractBlocks(strDestDir As String, _
Optional OverwriteExisting As Boolean = False) As Boolean
On Error GoTo ErrorHandler
Dim objSS As AcadSelectionSet
Dim objBlock As AcadBlockReference
Dim retVal As Variant
Dim i As Long
' Append backslash if required
If Not Right(strDestDir, 1) = "\" Then strDestDir = strDestDir & "\"
' Create destination directory if it doesn't exist
MakeSureDirectoryPathExists strDestDir
' Delete existing selection set
For Each objSS In ThisDrawing.SelectionSets
If StrComp(objSS.Name, "EXTRACT_BLOCKS", vbTextCompare) = 0 Then
objSS.Delete
Exit For
End If
Next
' Create a new selection set
Set objSS = ThisDrawing.SelectionSets.Add("EXTRACT_BLOCKS")
For i = 0 To ThisDrawing.ModelSpace.Count - 1
' Clear current selection set
objSS.Clear
If TypeOf ThisDrawing.ModelSpace.Item(i) Is AcadBlockReference Then
' PLace blockreference in the selection array
Set objBlock = ThisDrawing.ModelSpace.Item(i)
' Explode the block into a variant array of entities
retVal = objBlock.Explode
' Add the object into the selection set
objSS.AddItems retVal
' Check to see if the file exists
If Not Dir(strDestDir & objBlock.Name & ".dwg") = "" Then
' Check if we can overwrite an existing file and write if allowed
If OverwriteExisting = True Then
ThisDrawing.Wblock strDestDir & objBlock.Name & ".dwg", objSS
End If
Else
' Output the selection set to a new file
ThisDrawing.Wblock strDestDir & objBlock.Name & ".dwg", objSS
End If
DoEvents
End If
Next
' Remove our selection set
objSS.Delete
Set objSS = Nothing
Set objBlock = Nothing
Erase retVal
ExtractBlocks = True
Exit Function
ErrorHandler:
Set objSS = Nothing
Set objBlock = Nothing
Erase retVal
End Function
Add the following to the top of the module. It is a really neat API call that will create entire directory structures if they don't exist. For example: C:\Foo\Bar. If the following path does not exist, it will create each subdirectory as required.
Public Declare Function MakeSureDirectoryPathExists Lib "IMAGEHLP.DLL" (ByVal DirPath As String) As Long
Be sure to add in the IsDimArray function which checks to see if an array has been dimensioned before we try to clear it.
Public Function IsDimArray(arr As Variant) As Boolean
On Error GoTo ErrorHandler
Dim i As Long
i = UBound(arr)
If Not i = -1 Then IsDimArray = True
Exit Function
ErrorHandler:
IsDimArray = False
End Function
Finally, add the following subroutine which calls the main routine. Be sure you have a drawing open that has a few blocks in it before running the ExtractAllBlocks sub.
Public Sub ExtractAllBlocks()
If Not ExtractBlocks("C:\temp\allblocks") Then Stop
End Sub
The only real trick is exploding eahk block you find and exporting the entities in it. If we did not explode the block before writing it ou, we end up with a DWG file that has a block inside of it with the same name as the file...and this can not be inserted into another file.
Download: Extract All.zip
Well here I am after a VERY long break! I promise to be adding a few new articles in the near future, including some for Inventor.
A while ago I had the need to individually wblock out every block in a very large file, around 1500 blocks...The prospect of having to find and export every one by hand was not very appealing so I decided to whip up the bit of code below. Be sure to add all of this into a new module:
Public Function ExtractBlocks(strDestDir As String, _
Optional OverwriteExisting As Boolean = False) As Boolean
On Error GoTo ErrorHandler
Dim objSS As AcadSelectionSet
Dim objBlock As AcadBlockReference
Dim retVal As Variant
Dim i As Long
' Append backslash if required
If Not Right(strDestDir, 1) = "\" Then strDestDir = strDestDir & "\"
' Create destination directory if it doesn't exist
MakeSureDirectoryPathExists strDestDir
' Delete existing selection set
For Each objSS In ThisDrawing.SelectionSets
If StrComp(objSS.Name, "EXTRACT_BLOCKS", vbTextCompare) = 0 Then
objSS.Delete
Exit For
End If
Next
' Create a new selection set
Set objSS = ThisDrawing.SelectionSets.Add("EXTRACT_BLOCKS")
For i = 0 To ThisDrawing.ModelSpace.Count - 1
' Clear current selection set
objSS.Clear
If TypeOf ThisDrawing.ModelSpace.Item(i) Is AcadBlockReference Then
' PLace blockreference in the selection array
Set objBlock = ThisDrawing.ModelSpace.Item(i)
' Explode the block into a variant array of entities
retVal = objBlock.Explode
' Add the object into the selection set
objSS.AddItems retVal
' Check to see if the file exists
If Not Dir(strDestDir & objBlock.Name & ".dwg") = "" Then
' Check if we can overwrite an existing file and write if allowed
If OverwriteExisting = True Then
ThisDrawing.Wblock strDestDir & objBlock.Name & ".dwg", objSS
End If
Else
' Output the selection set to a new file
ThisDrawing.Wblock strDestDir & objBlock.Name & ".dwg", objSS
End If
DoEvents
End If
Next
' Remove our selection set
objSS.Delete
Set objSS = Nothing
Set objBlock = Nothing
Erase retVal
ExtractBlocks = True
Exit Function
ErrorHandler:
Set objSS = Nothing
Set objBlock = Nothing
Erase retVal
End Function
Add the following to the top of the module. It is a really neat API call that will create entire directory structures if they don't exist. For example: C:\Foo\Bar. If the following path does not exist, it will create each subdirectory as required.
Public Declare Function MakeSureDirectoryPathExists Lib "IMAGEHLP.DLL" (ByVal DirPath As String) As Long
Be sure to add in the IsDimArray function which checks to see if an array has been dimensioned before we try to clear it.
Public Function IsDimArray(arr As Variant) As Boolean
On Error GoTo ErrorHandler
Dim i As Long
i = UBound(arr)
If Not i = -1 Then IsDimArray = True
Exit Function
ErrorHandler:
IsDimArray = False
End Function
Finally, add the following subroutine which calls the main routine. Be sure you have a drawing open that has a few blocks in it before running the ExtractAllBlocks sub.
Public Sub ExtractAllBlocks()
If Not ExtractBlocks("C:\temp\allblocks") Then Stop
End Sub
The only real trick is exploding eahk block you find and exporting the entities in it. If we did not explode the block before writing it ou, we end up with a DWG file that has a block inside of it with the same name as the file...and this can not be inserted into another file.
