我想使用VBA执行分解非均匀缩放块
在这种情况下,只有一种方法可以使用SendCommand吗
请给我一些建议
- [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
|