exploding blocks thru vba
exploding blocks thru vba
(OP)
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
not sure of code to do this
just need the line to explode it...
any ideas





RE: exploding blocks thru vba
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.
RE: exploding blocks thru vba
RE: exploding blocks thru vba
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
RE: exploding blocks thru vba