exploding blocks thru vba

[rwbaker]

after a block is inserted I want to explode it.
not sure of code to do this

just need the line to explode it...

any ideas

 

[WMO]

From the help file:


RetVal = object.Explode

Object

3DPolyline , BlockRef, ExternalReference, LightweightPolyline, MInsertBlock, Polygonmesh, Polyline, Region
The object or objects this method applies to.

RetVal

Variant (array of objects)
The array of exploded objects.

 

[IFRs]

Can't you explode it as it is inserted, similar to the explode option on the Insert menu dialog?

 

[borgunit]

Keep in mind after you explode a block in VB, there then exists 2 items. The exploded block ents are "gathered" into an array of the objects and the block still remains also. You will need to delete the block object after exploding. Here is what I use to insert blocks. It is a little wordy but handles a lot of cases...

Public Function InsertBlkRef(ByVal strBlkName As String, _
Optional ByVal blnExplode As Boolean = True, _
Optional ByVal intSpace As Integer = 0, _
Optional ByVal dblScale As Double = 1#, _
Optional ByVal dblInsPnt As Variant, _
Optional ByVal dblRot As Double = 0#, _
Optional ByVal blnLastObj As Boolean = False) As AcadBlockReference
'------------------------------------------------------------------------------
'InsertBlkRef: Defaults are:
' EXPLODED
' MODELSPACE
' 1:1 SCALE
' 0,0 INSERT POINT
' 0 ROTATION
' True RETURN LAST EXPLODED ITEM (use after explode of block
' which reveals another block)
'Arguments: strBlkName = path and/or filename (i.e. "someblock.dwg")
' blnExplode = insert exploded TRUE or not explode FALSE
' intSpace(OPT) = 0 for paperspace and 1 (default) is modelspace
' dblScale(OPT) = scale, the same for X and Y
' dblInsPnt(OPT) = insertion point, zero-zero if none given
' dblRot(OPT) = rotation in degrees (converted to radians
' within function), defaults to zero if not given
'Returns: Block reference (if it is the only item in the block)
'------------------------------------------------------------------------------
Dim acBlkRef As AcadBlockReference
Dim dInsPt(0 To 2) As Double
Dim acBlkEnts
'''''''''''''''''''''''''''''''''''''''
On Error GoTo ErrHandler

'--------------------------------------------------------------------------
'Set insertion point. Set to 0,0 if none given
'--------------------------------------------------------------------------
If IsMissing(dblInsPnt) Then
dInsPt(0) = 0#: dInsPt(1) = 0#: dInsPt(2) = 0#
Else
dInsPt(0) = dblInsPnt(0)
dInsPt(1) = dblInsPnt(1)
dInsPt(2) = dblInsPnt(2)
End If

dblRot = DegreesToRadians(dblRot)
'--------------------------------------------------------------------------
'Check if need to add .dwg for pathed files
'--------------------------------------------------------------------------
If InStr(strBlkName, "\") And Not LCase(Right$(strBlkName, 4)) = ".dwg" Then
strBlkName = strBlkName & ".dwg"
End If
'--------------------------------------------------------------------------
'Set space to insert into. Then insert drawing
'--------------------------------------------------------------------------
If intSpace = 1 Then
Set acBlkRef = ThisDrawing.PaperSpace.InsertBlock(dInsPt, _
strBlkName, dblScale, dblScale, dblScale, dblRot)
Else
Set acBlkRef = ThisDrawing.ModelSpace.InsertBlock(dInsPt, _
strBlkName, dblScale, dblScale, dblScale, dblRot)
End If

'--------------------------------------------------------------------------
'Make sure block is inserted and explode if required
'--------------------------------------------------------------------------
If Not acBlkRef Is Nothing Then
If blnExplode Then
acBlkEnts = acBlkRef.Explode
acBlkRef.Delete 'Gets rid of original copy, leaves exploded one
If blnLastObj Then
Set InsertBlkRef = EntLast 'last modelspace entity
End If
Set acBlkRef = Nothing
Else
Set InsertBlkRef = acBlkRef
End If
End If

ExitHere:
Exit Function
ErrHandler:
Debug.Print vbObjectError + 514, "PP_ACAD Error", _
"Function 'InsertBlkRef' Failed"
End Function

Public Function DegreesToRadians(dblDegrees As Double) As Double
'------------------------------------------------------------------------------
'DegreesToRadians: Degrees to radians
'------------------------------------------------------------------------------
On Error GoTo Err_Control
DegreesToRadians = dblDegrees / 180 * (Atn(1) * 4)
Exit_Here:
Exit Function
Err_Control:
Select Case Err.Number
'Add additional Case selections here
Case Else
MsgBox Err.Description
Err.Clear
Resume Exit_Here
End Select
End Function

"Everybody is ignorant, only on different subjects." — Will Rogers

 

[rwbaker]

thanks to all the examples gave me exactly what i needed