ssArray返回包含于选择集中每一项目的变体数组
http://www.mjtd.com/function/list.asp?id=333&ordertype=bysort&orderkey=33 用图块的办法代码是简单一些，但不知道怎么回事，测试起来好像比前面的办法还要慢：（
'方法1
Sub getdrawingbox1() '通过制作图块再求图块的boundingbox
Dim bk As AcadBlock
Dim bror As AcadBlockReference
Dim ss As AcadSelectionSet
Dim po(0 To 2) As Double
On Error Resume Next
po(0) = 0
po(1) = 0
po(2) = 0
Dim boxp(0 To 1) As Variant
Set bk = ThisDrawing.Blocks.Add(po, "tempb")
Set ss = ThisDrawing.SelectionSets("ssss")
If Err Then
Err.Clear
Set ss = ThisDrawing.SelectionSets.Add("ssss")
End If
ss.Select acSelectionSetAll
ThisDrawing.CopyObjects ssArray(ss), bk
Set bror = ThisDrawing.ModelSpace.InsertBlock(po, "tempb", 1, 1, 1, 0)
bror.GetBoundingBox boxp(0), boxp(1)
Dim poly1 As AcadPolyline
Dim pllist(0 To 11) As Double
pllist(0) = boxp(0)(0)
pllist(1) = boxp(0)(1)
pllist(2) = 0
pllist(3) = boxp(0)(0)
pllist(4) = boxp(1)(1)
pllist(5) = 0
pllist(6) = boxp(1)(0)
pllist(7) = boxp(1)(1)
pllist(8) = 0
pllist(9) = boxp(1)(0)
pllist(10) = boxp(0)(1)
pllist(11) = 0
ss.Clear
bror.Delete
bk.Delete
Set poly1 = ThisDrawing.ModelSpace.AddPolyline(pllist)
poly1.Closed = True
poly1.Color = 1
End Sub
Function ssArray(ss As AcadSelectionSet)
Dim retVal() As AcadEntity, i As Long
ReDim retVal(0 To ss.Count - 1)
For i = 0 To ss.Count - 1
Set retVal(i) = ss.Item(i)
Next
ssArray = retVal
End Function
'******************************方法2
Sub getdrawingbox2() '通过各个实体的boundingbox求出
Dim acaddoc As AcadDocument
Set acaddoc = ThisDrawing
Dim ss As AcadSelectionSet
On Error Resume Next
Set ss = acaddoc.SelectionSets("ssss")
If Err Then
Err.Clear
Set ss = acaddoc.SelectionSets.Add("ssss")
End If
ss.Clear
ss.Select acSelectionSetAll
Dim poinsss As Variant
boxp = ssExtents(ss)
Dim poly1 As AcadPolyline
Dim pllist(0 To 11) As Double
pllist(0) = boxp(0)(0)
pllist(1) = boxp(0)(1)
pllist(2) = 0
pllist(3) = boxp(0)(0)
pllist(4) = boxp(1)(1)
pllist(5) = 0
pllist(6) = boxp(1)(0)
pllist(7) = boxp(1)(1)
pllist(8) = 0
pllist(9) = boxp(1)(0)
pllist(10) = boxp(0)(1)
pllist(11) = 0
ss.Clear
bror.Delete
bk.Delete
Set poly1 = ThisDrawing.ModelSpace.AddPolyline(pllist)
poly1.Closed = True
poly1.Color = 1
ss.Clear
ss.Delete
End Sub
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
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
页:
1
[2]