如何获得整个文档的BoundingBox？

mccad

把图形中的所有对象做成一个图块，只用一次的取边框就行，这样速度会快很多吧

topirol

请问用什么方法来把选择集转成一个图块？

mccad

将选择集中的对象转换到一个数组中，然后通过数组来生成图块，再插入图块。
ssArray  返回包含于选择集中每一项目的变体数组  
http://www.mjtd.com/function/list.asp?id=333&ordertype=bysort&orderkey=33

topirol

用图块的办法代码是简单一些，但不知道怎么回事，测试起来好像比前面的办法还要慢：（

2. '方法1
   
3. Sub getdrawingbox1() '通过制作图块再求图块的boundingbox
   
4. Dim bk As AcadBlock
   
5. Dim bror As AcadBlockReference
   
6. Dim ss As AcadSelectionSet
   
7. Dim po(0 To 2) As Double
   
8. On Error Resume Next
   
9. 
   
10. po(0) = 0
    
11. po(1) = 0
    
12. po(2) = 0
    
13. 
    
14. Dim boxp(0 To 1) As Variant
    
15. Set bk = ThisDrawing.Blocks.Add(po, "tempb")
    
16. 
    
17. 
    
18. 
    
19. Set ss = ThisDrawing.SelectionSets("ssss")
    
20. If Err Then
    
21. Err.Clear
    
22. 
    
23. Set ss = ThisDrawing.SelectionSets.Add("ssss")
    
24. 
    
25. End If
    
26. 
    
27. ss.Select acSelectionSetAll
    
28. 
    
29. 
    
30. 
    
31. ThisDrawing.CopyObjects ssArray(ss), bk
    
32. Set bror = ThisDrawing.ModelSpace.InsertBlock(po, "tempb", 1, 1, 1, 0)
    
33. 
    
34. bror.GetBoundingBox boxp(0), boxp(1)
    
35. Dim poly1 As AcadPolyline
    
36. Dim pllist(0 To 11) As Double
    
37. pllist(0) = boxp(0)(0)
    
38. pllist(1) = boxp(0)(1)
    
39. pllist(2) = 0
    
40. pllist(3) = boxp(0)(0)
    
41. pllist(4) = boxp(1)(1)
    
42. pllist(5) = 0
    
43. pllist(6) = boxp(1)(0)
    
44. pllist(7) = boxp(1)(1)
    
45. pllist(8) = 0
    
46. pllist(9) = boxp(1)(0)
    
47. pllist(10) = boxp(0)(1)
    
48. pllist(11) = 0
    
49. ss.Clear
    
50. bror.Delete
    
51. bk.Delete
    
52. Set poly1 = ThisDrawing.ModelSpace.AddPolyline(pllist)
    
53. poly1.Closed = True
    
54. poly1.Color = 1
    
55. 
    
56. End Sub
    
57. 
    
58. Function ssArray(ss As AcadSelectionSet)
    
59. 
    
60.     Dim retVal() As AcadEntity, i As Long
    
61.    
    
62.     ReDim retVal(0 To ss.Count - 1)
    
63.    
    
64.     For i = 0 To ss.Count - 1
    
65.         Set retVal(i) = ss.Item(i)
    
66.     Next
    
67.    
    
68.     ssArray = retVal
    
69. 
    
70. End Function
    
71. 
    
72. 
    
73. 
    
74. '******************************方法2
    
75. Sub getdrawingbox2() '通过各个实体的boundingbox求出
    
76. 
    
77. Dim acaddoc As AcadDocument
    
78. Set acaddoc = ThisDrawing
    
79. Dim ss As AcadSelectionSet
    
80. On Error Resume Next
    
81. 
    
82. Set ss = acaddoc.SelectionSets("ssss")
    
83. If Err Then
    
84. Err.Clear
    
85. Set ss = acaddoc.SelectionSets.Add("ssss")
    
86. End If
    
87. 
    
88. ss.Clear
    
89. 
    
90. 
    
91. ss.Select acSelectionSetAll
    
92. 
    
93. Dim poinsss As Variant
    
94. boxp = ssExtents(ss)
    
95. 
    
96. 
    
97. 
    
98. Dim poly1 As AcadPolyline
    
99. Dim pllist(0 To 11) As Double
    
100. pllist(0) = boxp(0)(0)
     
101. pllist(1) = boxp(0)(1)
     
102. pllist(2) = 0
     
103. pllist(3) = boxp(0)(0)
     
104. pllist(4) = boxp(1)(1)
     
105. pllist(5) = 0
     
106. pllist(6) = boxp(1)(0)
     
107. pllist(7) = boxp(1)(1)
     
108. pllist(8) = 0
     
109. pllist(9) = boxp(1)(0)
     
110. pllist(10) = boxp(0)(1)
     
111. pllist(11) = 0
     
112. ss.Clear
     
113. bror.Delete
     
114. bk.Delete
     
115. Set poly1 = ThisDrawing.ModelSpace.AddPolyline(pllist)
     
116. poly1.Closed = True
     
117. poly1.Color = 1
     
118. ss.Clear
     
119. ss.Delete
     
120. End Sub
     
121. 
     
122. Public Function ssExtents(ss As AcadSelectionSet) As Variant
     
123. 
     
124.     Dim points(), c As Long
     
125. 
     
126.     Dim min, max, util As AcadUtility
     
127.    
     
128.     Set util = ThisDrawing.Utility
     
129.    
     
130.     c = 0
     
131.    
     
132.     For i = 0 To ss.Count - 1
     
133.         
     
134.         ss.Item(i).GetBoundingBox min, max
     
135.         min = util.TranslateCoordinates(min, acWorld, acUCS, False)
     
136.         max = util.TranslateCoordinates(max, acWorld, acUCS, False)
     
137.         ReDim Preserve points(0 To c + 1)
     
138.         points(c) = min: points(c + 1) = max
     
139.         c = c + 2
     
140.         
     
141.     Next
     
142.         
     
143.     ssExtents = Extents(points)
     
144. 
     
145. End Function
     
146. 
     
147. Public Function Extents(points)
     
148. 
     
149.     Dim min, max
     
150.     Dim i As Long, j As Long, pt, retVal(0 To 1)
     
151.    
     
152.     min = points(LBound(points))
     
153.     max = points(LBound(points))
     
154.         
     
155.     For i = LBound(points) To UBound(points)
     
156.         pt = points(i)
     
157.         For j = LBound(pt) To UBound(pt)
     
158.             If pt(j) < min(j) Then min(j) = pt(j)
     
159.             If pt(j) > max(j) Then max(j) = pt(j)
     
160.         Next
     
161.     Next
     
162.    
     
163.     retVal(0) = min: retVal(1) = max
     
164.     Extents = retVal
     
165. 
     
166. End Function
     
167. 
     
168. 
     
169. 
     
170. 
     

'方法1<br /> Sub getdrawingbox1() '通过制作图块再求图块的boundingbox<br /> Dim bk As AcadBlock<br /> Dim bror As AcadBlockReference<br /> Dim ss As AcadSelectionSet<br /> Dim po(0 To 2) As Double<br /> On Error Resume Next<br /> <br /> po(0) = 0<br /> po(1) = 0<br /> po(2) = 0<br /> <br /> Dim boxp(0 To 1) As Variant<br /> Set bk = ThisDrawing.Blocks.Add(po, "tempb")<br /> <br /> <br /> <br /> Set ss = ThisDrawing.SelectionSets("ssss")<br /> If Err Then<br /> Err.Clear<br /> <br /> Set ss = ThisDrawing.SelectionSets.Add("ssss")<br /> <br /> End If<br /> <br /> ss.Select acSelectionSetAll<br /> <br /> <br /> <br /> ThisDrawing.CopyObjects ssArray(ss), bk<br /> Set bror = ThisDrawing.ModelSpace.InsertBlock(po, "tempb", 1, 1, 1, 0)<br /> <br /> bror.GetBoundingBox boxp(0), boxp(1)<br /> Dim poly1 As AcadPolyline<br /> Dim pllist(0 To 11) As Double<br /> pllist(0) = boxp(0)(0)<br /> pllist(1) = boxp(0)(1)<br /> pllist(2) = 0<br /> pllist(3) = boxp(0)(0)<br /> pllist(4) = boxp(1)(1)<br /> pllist(5) = 0<br /> pllist(6) = boxp(1)(0)<br /> pllist(7) = boxp(1)(1)<br /> pllist(8) = 0<br /> pllist(9) = boxp(1)(0)<br /> pllist(10) = boxp(0)(1)<br /> pllist(11) = 0<br /> ss.Clear<br /> bror.Delete<br /> bk.Delete<br /> Set poly1 = ThisDrawing.ModelSpace.AddPolyline(pllist)<br /> poly1.Closed = True<br /> poly1.Color = 1<br /> <br /> End Sub<br /> <br /> Function ssArray(ss As AcadSelectionSet)<br /> <br />     Dim retVal() As AcadEntity, i As Long<br />     <br />     ReDim retVal(0 To ss.Count - 1)<br />     <br />     For i = 0 To ss.Count - 1<br />         Set retVal(i) = ss.Item(i)<br />     Next<br />     <br />     ssArray = retVal<br /> <br /> End Function<br /> <br /> <br /> <br /> '******************************方法2<br /> Sub getdrawingbox2() '通过各个实体的boundingbox求出<br /> <br /> Dim acaddoc As AcadDocument<br /> Set acaddoc = ThisDrawing<br /> Dim ss As AcadSelectionSet<br /> On Error Resume Next<br /> <br /> Set ss = acaddoc.SelectionSets("ssss")<br /> If Err Then<br /> Err.Clear<br /> Set ss = acaddoc.SelectionSets.Add("ssss")<br /> End If<br /> <br /> ss.Clear<br /> <br /> <br /> ss.Select acSelectionSetAll<br /> <br /> Dim poinsss As Variant<br /> boxp = ssExtents(ss)<br /> <br /> <br /> <br /> Dim poly1 As AcadPolyline<br /> Dim pllist(0 To 11) As Double<br /> pllist(0) = boxp(0)(0)<br /> pllist(1) = boxp(0)(1)<br /> pllist(2) = 0<br /> pllist(3) = boxp(0)(0)<br /> pllist(4) = boxp(1)(1)<br /> pllist(5) = 0<br /> pllist(6) = boxp(1)(0)<br /> pllist(7) = boxp(1)(1)<br /> pllist(8) = 0<br /> pllist(9) = boxp(1)(0)<br /> pllist(10) = boxp(0)(1)<br /> pllist(11) = 0<br /> ss.Clear<br /> bror.Delete<br /> bk.Delete<br /> Set poly1 = ThisDrawing.ModelSpace.AddPolyline(pllist)<br /> poly1.Closed = True<br /> poly1.Color = 1<br /> ss.Clear<br /> ss.Delete<br /> End Sub<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 /> 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 /> <br /> <br /> <br />