分解非均匀缩放的块
我想使用VBA执行爆炸非均匀缩放块。在这种情况下，是否只有一种方法可以使用 SendCommand？
请提出建议。
'Bellow code is written by Randall Rath---------------------
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
**** Hidden Message ***** 太可惜了..
无论如何，谢谢布里科，格伦R..
页:
[1]