I would like to perform Explode non-uniform scaled Blocks using VBA.
In this case, Is there only one way using SendCommand?
Suggestions please.
[color=green]'Bellow code is written by Randall Rath---------------------[/color]
Public Function ExplodeEX(oBlkRef As AcadBlockReference, _
bKeep As Boolean) As Variant
Dim objEnt As AcadEntity
Dim objMT As AcadMText
Dim objBlk As AcadBlock
Dim objDoc As AcadDocument
Dim objArray() As AcadEntity
Dim objSpace As AcadBlock
Dim intCnt As Integer
Dim varTemp As Variant
Dim varPnt As Variant
Dim dblScale As Double
Dim dblRot As Double
Dim dblMatrix(3, 3) As Double
On Error GoTo Err_Control
'What document is the reference in?
Set objDoc = oBlkRef.Document
'Model space or layout?
Set objSpace = objDoc.ObjectIdToObject(oBlkRef.OwnerID)
Set objBlk = objDoc.Blocks(oBlkRef.Name)
varPnt = oBlkRef.InsertionPoint
dblScale = oBlkRef.XScaleFactor
dblRot = oBlkRef.Rotation
'Set the matrix for new objects transform
'*Note:
'This matrix uses only the X scale factor of the
'Block reference, many entities can not be scaled
'Non-uniformly!
dblMatrix(0, 0) = dblScale
dblMatrix(0, 1) = 0
dblMatrix(0, 2) = 0
dblMatrix(0, 3) = varPnt(0)
dblMatrix(1, 0) = 0
dblMatrix(1, 1) = dblScale
dblMatrix(1, 2) = 0
dblMatrix(1, 3) = varPnt(1)
dblMatrix(2, 0) = 0
dblMatrix(2, 1) = 0
dblMatrix(2, 2) = dblScale
dblMatrix(2, 3) = varPnt(2)
dblMatrix(3, 0) = 0
dblMatrix(3, 1) = 0
dblMatrix(3, 2) = 0
dblMatrix(3, 3) = 1
'Get all of the entities in the block
ReDim objArray(objBlk.Count - 1)
For Each objEnt In objBlk
Set objArray(intCnt) = objEnt
intCnt = intCnt + 1
Next objEnt
'Place them into the correct space
varTemp = objDoc.CopyObjects(objArray, objSpace)
'Transform & rotate
For intCnt = LBound(varTemp) To UBound(varTemp)
Set objEnt = varTemp(intCnt)
objEnt.TransformBy dblMatrix
objEnt.Rotate varPnt, dblRot
Next intCnt
'Keep the block reference?
If Not bKeep Then
oBlkRef.Delete
End If
'Return all of the new entities
ExplodeEX = varTemp
'Release memory
Set objDoc = Nothing
Set objBlk = Nothing
Set objSpace = Nothing
Exit_Here:
Exit Function
Err_Control:
MsgBox Err.Description
Resume Exit_Here
End Function