这样行吗?- 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 FunctionPublic 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 FunctionPublic 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 FunctionSub kr_limit()
- Dim ss As AcadSelectionSet
- Set ss = CreateSelectionSet
- ss.Select acSelectionSetAll
- Dim retVal
- retVal = ssExtents(ss)End Sub
|