班主，我的外扩内扩问题，怎么没人回答呀？
See the topichttp://bbs.mjtd.com/forum.php?mod=viewthread&tid=12402
我的意思是向四周扩，和原来的闭全图形等距离。 做成图块，然后计算按不等比例插入方式插入。 再详细一点：
先取得要外扩的图形做为选择集；
通过选择集的每一对象取得总的选择集的长(X)和宽(Y)以及中心CP)(用GetBoundingBox方法 );
将选择集生成的图块(用WBlock);
按照需要的外扩的值(Z)计算X向和Y向的插入比例：
X1=(X+2Z)/X
Y1=(Y+2Z)/Y
由于生成图块的方法没有提供插入点功能，所以要取得图块的中心点然后再移动图块到原先选择集的中心点。
这样就结束了。 能给段代码吗？ 没有时间整理好一点，也没有加入出错捕捉语句：
Sub ExObjs()
'先取得要外扩的图形做为选择集；
Dim ss As AcadSelectionSet
Set ss = CreateSelectionSet
ss.SelectOnScreen
Dim z As Double
z = ThisDrawing.Utility.GetDistance(, "输入扩边的距离：")
'通过选择集的每一对象取得总的选择集的长(X)和宽(Y)以及中心CP)(用GetBoundingBox方法 );
Dim box As Variant
box = ssExtents(ss)
Dim cp As Variant
Dim x As Double
Dim y As Double
cp = GetCenterPoint(box, x, y)
'按照需要的外扩的值(Z)计算X向和Y向的插入比例：
Dim x1 As Double
Dim y1 As Double
x1 = (x + 2 * z) / x
y1 = (y + 2 * z) / y
'将选择集生成的图块
Dim objBlk As AcadBlock
Set objBlk = ThisDrawing.Blocks.Add(cp, "*U")
Dim varObjs As Variant
varObjs = sset2var(ss)
ThisDrawing.CopyObjects varObjs, objBlk
Dim blkName As String
blkName = objBlk.Name
Dim blkref As AcadBlockReference
Set blkref = ThisDrawing.ModelSpace.InsertBlock(cp, blkName, x1, y1, 1, 0)
'blkref.Explode
'blkref.Delete
End Sub
Function GetCenterPoint(points As Variant, ByRef x As Double, ByRef y As Double) As Variant
Dim i As Integer
Dim cp(2) As Double
Dim MaxPnt As Variant
Dim MinPnt As Variant
MinPnt = points(0)
MaxPnt = points(1)
cp(0) = (MinPnt(0) + MaxPnt(0)) / 2
cp(1) = (MinPnt(1) + MaxPnt(1)) / 2
x = MaxPnt(0) - MinPnt(0)
y = MaxPnt(1) - MinPnt(1)
GetCenterPoint = cp
End Function
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
Dim ss As AcadSelectionSet
On Error Resume Next
Set ss = ThisDrawing.SelectionSets(ssName)
If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
ss.Clear
Set CreateSelectionSet = ss
End Function
Public Function Extents(points)
Dim min, max
Dim i As Long, j As Long, pt, retVal(0 To 1)
min = points(LBound(points))
max = points(LBound(points))
For i = LBound(points) To UBound(points)
pt = points(i)
For j = LBound(pt) To UBound(pt)
If pt(j) < min(j) Then min(j) = pt(j)
If pt(j) > max(j) Then max(j) = pt(j)
Next
Next
retVal(0) = min: retVal(1) = max
Extents = retVal
End Function
Public Function ssExtents(ss As AcadSelectionSet) As Variant
Dim points(), c As Long
Dim min, max, util As AcadUtility
Set util = ThisDrawing.Utility
c = 0
For i = 0 To ss.Count - 1
ss.Item(i).GetBoundingBox min, max
min = util.TranslateCoordinates(min, acWorld, acUCS, False)
max = util.TranslateCoordinates(max, acWorld, acUCS, False)
ReDim Preserve points(0 To c + 1)
points(c) = min: points(c + 1) = max
c = c + 2
Next
ssExtents = Extents(points)
End Function
Function sset2var(ss As AcadSelectionSet) As Variant
Dim i As Integer
Dim varObjs() As AcadEntity
i = ss.Count - 1
ReDim varObjs(i) As AcadEntity
For i = 0 To ss.Count - 1
Set varObjs(i) = ss(i)
Next
sset2var = varObjs
End Function
So thanks
我看看，问题再问你！ 又发现ActiveX的一个BUG。
插入图块时，如果图块X、Y比例不同时，则插入后不能用Explode方法炸开。只能用SendCommand方法引用命令的方式炸开。
页:
[1]