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.

Comments: Post a Comment

<< Home

This page is powered by Blogger. Isn't yours?

vba, acad vba, cad vba, cad, visual basic, visual basic for applications, autocad vba, acad vba, training, vba training, cad training, acad training, autocad training, autocad vba training, bom, bill of material, meta-data, meta data, metadata, property data, data, inventor properties, document management, document, management,technical support resource for users of Autodesk Mechanical CAD Software including Autodesk Inventor & Mechanical Desktop inventor, autodeskinventor, inventor 2, inventor 3, inventor 4, inventor 5, inventor 6, inventor7, inventor 8, inventor 9, inventor 10, autodesk inventor, autodesk inventor2, autodesk inventor 3, autodesk inventor 4, autodesk inventor 5, autodeskinventor 6, autodesk inventor 7, autodesk inventor 8, autodesk inventor9, autodesk inventor 10, inventor r, inventor r2, inventor r3, inventor r4, inventor r5, inventor r6, inventor r7, inventor r8, inventor r9, inventorr10, autodesk inventor, autodesk inventor r2, autodesk inventor r3, autodeskinventor r4, autodesk inventor r5, autodesk inventor r6, autodesk inventorr7, autodesk inventor r8, autodesk inventor r9, autodesk inventor r10,inventor series, autodesk inventor series, inventor series 5, inventorseries R5, autodesk inventor series 5, autodesk inventor series r5, inventorseries 6, inventor series R6, autodesk inventor series 6, autodesk inventorseries r6, inventor autodesk, autodesk inventor download, autodesk inventortutorial, autodesk inventor help, autodesk inventor faq, autodesk inventortips, autodesk inventor routines, autodesk inventor support, autodesk inventor, inventor download, inventor tutorial, inventor help, inventorfaq, inventor tips, inventor routines, inventor support, inventor, inventor help line, help for inventor, inventortraining, autodesk inventor training, mdt, mdt 4, mdt 5,mdt 6, mdt 7, mdt 8, mdt4, mdt5, mdt6, mdt7, mdt8, mdt 2000, mdt 2002,mdt r4, mdt r5, mdt r6, mdt r2000, mdt r2002, mechanical desktop, mechanicaldesktop 4, mechanical desktop 5, mechanical desktop 6, mechanical desktop7, mechanical desktop 2000, mechanical desktop 2002, autodesk, autodesk auto cad, autodesk inc,training, education, auto cad support, autocad support, mcad, autocad mechanical,mechanical, autocad mechanical 6, autocad mechanical 7, autocad mechanical8, autocad mechanical 9, autocad mechanical r6, autocad mechanical r7,autocad mechanical r8, autocad mechanical r9, support, help, tips, routines, reseller, mech, cad, acad, technical, ontario, canada, f.a.q.,faq, answers, resource, barrie, autolisp, auto lisp, autocad, auto cad, autocad desktop, auto cad desktop, autocad inventor, auto cadinventor, powerpack, MAI, desktop, cad software, autocad lt, auto cad lt,cad cam, cad design, cad job, job cad, autocad lisp, auto cad lisp, 3dcad software, 3d cad, free, free cad software, service pack, render, system, computer, aided, drafting, design, manufacturing, modeling, solidmodeling, solid modelling