分解非均匀缩放块

[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