班主，我的外扩内扩问题，怎么没人回答呀？

wjfling

See the topic
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=12402

我的意思是向四周扩，和原来的闭全图形等距离。

mccad

做成图块，然后计算按不等比例插入方式插入。

mccad

再详细一点：
先取得要外扩的图形做为选择集；
通过选择集的每一对象取得总的选择集的长(X)和宽(Y)以及中心CP)(用GetBoundingBox方法 );
将选择集生成的图块(用WBlock);
按照需要的外扩的值(Z)计算X向和Y向的插入比例：
X1=(X+2Z)/X
Y1=(Y+2Z)/Y
由于生成图块的方法没有提供插入点功能，所以要取得图块的中心点然后再移动图块到原先选择集的中心点。
这样就结束了。

wjfling

能给段代码吗？

mccad

没有时间整理好一点，也没有加入出错捕捉语句：

2. 
   
3. Sub ExObjs()
   
4. '先取得要外扩的图形做为选择集；
   
5.     Dim ss As AcadSelectionSet
   
6.     Set ss = CreateSelectionSet
   
7.     ss.SelectOnScreen
   
8.     Dim z As Double
   
9.     z = ThisDrawing.Utility.GetDistance(, "输入扩边的距离：")
   
10. '通过选择集的每一对象取得总的选择集的长(X)和宽(Y)以及中心CP)(用GetBoundingBox方法 );
    
11.     Dim box As Variant
    
12.     box = ssExtents(ss)
    
13.     Dim cp As Variant
    
14.     Dim x As Double
    
15.     Dim y As Double
    
16.     cp = GetCenterPoint(box, x, y)
    
17.    
    
18. '按照需要的外扩的值(Z)计算X向和Y向的插入比例：
    
19.     Dim x1 As Double
    
20.     Dim y1 As Double
    
21.     x1 = (x + 2 * z) / x
    
22.     y1 = (y + 2 * z) / y
    
23. '将选择集生成的图块
    
24.     Dim objBlk As AcadBlock
    
25.     Set objBlk = ThisDrawing.Blocks.Add(cp, "*U")
    
26.     Dim varObjs As Variant
    
27.     varObjs = sset2var(ss)
    
28.     ThisDrawing.CopyObjects varObjs, objBlk
    
29.    
    
30.     Dim blkName As String
    
31.     blkName = objBlk.Name
    
32.     Dim blkref As AcadBlockReference
    
33.     Set blkref = ThisDrawing.ModelSpace.InsertBlock(cp, blkName, x1, y1, 1, 0)
    
34.     'blkref.Explode
    
35.     'blkref.Delete
    
36. End Sub
    
37. 
    
38. Function GetCenterPoint(points As Variant, ByRef x As Double, ByRef y As Double) As Variant
    
39.     Dim i As Integer
    
40.     Dim cp(2) As Double
    
41.     Dim MaxPnt As Variant
    
42.     Dim MinPnt As Variant
    
43.     MinPnt = points(0)
    
44.     MaxPnt = points(1)
    
45.     cp(0) = (MinPnt(0) + MaxPnt(0)) / 2
    
46.     cp(1) = (MinPnt(1) + MaxPnt(1)) / 2
    
47.     x = MaxPnt(0) - MinPnt(0)
    
48.     y = MaxPnt(1) - MinPnt(1)
    
49.     GetCenterPoint = cp
    
50. End Function
    
51. Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
    
52. 
    
53.     Dim ss As AcadSelectionSet
    
54.    
    
55.     On Error Resume Next
    
56.     Set ss = ThisDrawing.SelectionSets(ssName)
    
57.     If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    
58.     ss.Clear
    
59.     Set CreateSelectionSet = ss
    
60. 
    
61. End Function
    
62. 
    
63. Public Function Extents(points)
    
64. 
    
65.     Dim min, max
    
66.     Dim i As Long, j As Long, pt, retVal(0 To 1)
    
67.    
    
68.     min = points(LBound(points))
    
69.     max = points(LBound(points))
    
70.         
    
71.     For i = LBound(points) To UBound(points)
    
72.         pt = points(i)
    
73.         For j = LBound(pt) To UBound(pt)
    
74.             If pt(j) < min(j) Then min(j) = pt(j)
    
75.             If pt(j) > max(j) Then max(j) = pt(j)
    
76.         Next
    
77.     Next
    
78.    
    
79.     retVal(0) = min: retVal(1) = max
    
80.     Extents = retVal
    
81. 
    
82. End Function
    
83. 
    
84. Public Function ssExtents(ss As AcadSelectionSet) As Variant
    
85. 
    
86.     Dim points(), c As Long
    
87. 
    
88.     Dim min, max, util As AcadUtility
    
89.    
    
90.     Set util = ThisDrawing.Utility
    
91.    
    
92.     c = 0
    
93.    
    
94.     For i = 0 To ss.Count - 1
    
95.         
    
96.         ss.Item(i).GetBoundingBox min, max
    
97.         min = util.TranslateCoordinates(min, acWorld, acUCS, False)
    
98.         max = util.TranslateCoordinates(max, acWorld, acUCS, False)
    
99.         ReDim Preserve points(0 To c + 1)
    
100.         points(c) = min: points(c + 1) = max
     
101.         c = c + 2
     
102.         
     
103.     Next
     
104.         
     
105.     ssExtents = Extents(points)
     
106. 
     
107. End Function
     
108. 
     
109. Function sset2var(ss As AcadSelectionSet) As Variant
     
110.     Dim i As Integer
     
111.     Dim varObjs() As AcadEntity
     
112.     i = ss.Count - 1
     
113.     ReDim varObjs(i) As AcadEntity
     
114.     For i = 0 To ss.Count - 1
     
115.      Set varObjs(i) = ss(i)
     
116.     Next
     
117.     sset2var = varObjs
     
118.    
     
119. End Function
     

<br /> Sub ExObjs()<br /> '先取得要外扩的图形做为选择集；<br />     Dim ss As AcadSelectionSet<br />     Set ss = CreateSelectionSet<br />     ss.SelectOnScreen<br />     Dim z As Double<br />     z = ThisDrawing.Utility.GetDistance(, "输入扩边的距离：")<br /> '通过选择集的每一对象取得总的选择集的长(X)和宽(Y)以及中心CP)(用GetBoundingBox方法 );<br />     Dim box As Variant<br />     box = ssExtents(ss)<br />     Dim cp As Variant<br />     Dim x As Double<br />     Dim y As Double<br />     cp = GetCenterPoint(box, x, y)<br />     <br /> '按照需要的外扩的值(Z)计算X向和Y向的插入比例：<br />     Dim x1 As Double<br />     Dim y1 As Double<br />     x1 = (x + 2 * z) / x<br />     y1 = (y + 2 * z) / y<br /> '将选择集生成的图块<br />     Dim objBlk As AcadBlock<br />     Set objBlk = ThisDrawing.Blocks.Add(cp, "*U")<br />     Dim varObjs As Variant<br />     varObjs = sset2var(ss)<br />     ThisDrawing.CopyObjects varObjs, objBlk<br />     <br />     Dim blkName As String<br />     blkName = objBlk.Name<br />     Dim blkref As AcadBlockReference<br />     Set blkref = ThisDrawing.ModelSpace.InsertBlock(cp, blkName, x1, y1, 1, 0)<br />     'blkref.Explode<br />     'blkref.Delete<br /> End Sub<br /> <br /> Function GetCenterPoint(points As Variant, ByRef x As Double, ByRef y As Double) As Variant<br />     Dim i As Integer<br />     Dim cp(2) As Double<br />     Dim MaxPnt As Variant<br />     Dim MinPnt As Variant<br />     MinPnt = points(0)<br />     MaxPnt = points(1)<br />     cp(0) = (MinPnt(0) + MaxPnt(0)) / 2<br />     cp(1) = (MinPnt(1) + MaxPnt(1)) / 2<br />     x = MaxPnt(0) - MinPnt(0)<br />     y = MaxPnt(1) - MinPnt(1)<br />     GetCenterPoint = cp<br /> End Function<br /> Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet<br /> <br />     Dim ss As AcadSelectionSet<br />     <br />     On Error Resume Next<br />     Set ss = ThisDrawing.SelectionSets(ssName)<br />     If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)<br />     ss.Clear<br />     Set CreateSelectionSet = ss<br /> <br /> End Function<br /> <br /> Public Function Extents(points)<br /> <br />     Dim min, max<br />     Dim i As Long, j As Long, pt, retVal(0 To 1)<br />     <br />     min = points(LBound(points))<br />     max = points(LBound(points))<br />         <br />     For i = LBound(points) To UBound(points)<br />         pt = points(i)<br />         For j = LBound(pt) To UBound(pt)<br />             If pt(j) < min(j) Then min(j) = pt(j)<br />             If pt(j) > max(j) Then max(j) = pt(j)<br />         Next<br />     Next<br />     <br />     retVal(0) = min: retVal(1) = max<br />     Extents = retVal<br /> <br /> End Function<br /> <br /> Public Function ssExtents(ss As AcadSelectionSet) As Variant<br /> <br />     Dim points(), c As Long<br /> <br />     Dim min, max, util As AcadUtility<br />     <br />     Set util = ThisDrawing.Utility<br />     <br />     c = 0<br />     <br />     For i = 0 To ss.Count - 1<br />         <br />         ss.Item(i).GetBoundingBox min, max<br />         min = util.TranslateCoordinates(min, acWorld, acUCS, False)<br />         max = util.TranslateCoordinates(max, acWorld, acUCS, False)<br />         ReDim Preserve points(0 To c + 1)<br />         points(c) = min: points(c + 1) = max<br />         c = c + 2<br />         <br />     Next<br />         <br />     ssExtents = Extents(points)<br /> <br /> End Function<br /> <br /> Function sset2var(ss As AcadSelectionSet) As Variant<br />     Dim i As Integer<br />     Dim varObjs() As AcadEntity<br />     i = ss.Count - 1<br />     ReDim varObjs(i) As AcadEntity<br />     For i = 0 To ss.Count - 1<br />      Set varObjs(i) = ss(i)<br />     Next<br />     sset2var = varObjs<br />     <br /> End Function<br />

wjfling

So thanks
我看看，问题再问你！

mccad

又发现ActiveX的一个BUG。
插入图块时，如果图块X、Y比例不同时，则插入后不能用Explode方法炸开。只能用SendCommand方法引用命令的方式炸开。