Sset的绝对中心

Option Explicit
Sub GetSelectionCenter()
     Dim oSset As AcadSelectionSet
     Dim oEnt As AcadEntity
     Dim xmin As Double, xmax As Double
     Dim ymin As Double, ymax As Double
     Dim i As Integer
     Dim lp(0 To 2) As Double
     Dim up(0 To 2) As Double
     
          With ThisDrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          Set oSset = .Add("TestSet")
          End With
     oSset.SelectOnScreen
     ReDim xcoords(0 To (oSset.Count - 1) * 2) As Double
     ReDim ycoords(0 To (oSset.Count - 1) * 2) As Double
For Each oEnt In oSset
    Dim minExt As Variant
    Dim maxExt As Variant
    oEnt.GetBoundingBox minExt, maxExt
    xcoords(i) = minExt(0): xcoords(i + 1) = maxExt(0)
    ycoords(i) = minExt(1): ycoords(i + 1) = maxExt(1)
    i = i + 1
Next
xmin = SortDesc(xcoords)(0): ymin = SortDesc(ycoords)(0)
xmax = SortAsc(xcoords)(0): ymax = SortAsc(ycoords)(0)
lp(0) = xmin: lp(1) = ymin: lp(2) = 0#
up(0) = xmax: up(1) = ymax: up(2) = 0#
Dim minPt As Variant
Dim maxPt As Variant
Dim cpt As Variant
Dim centPt(2) As Double
With ThisDrawing.Utility
minPt = .TranslateCoordinates(lp, acUCS, acWorld, False)
maxPt = .TranslateCoordinates(up, acUCS, acWorld, False)
centPt(0) = (minPt(0) + maxPt(0)) / 2: centPt(1) = (minPt(1) + maxPt(1)) / 2: centPt(2) = 0#
cpt = .TranslateCoordinates(centPt, acUCS, acWorld, False)
End With
'for visualization only:
Dim oCirc As AcadCircle
Set oCirc = ThisDrawing.ModelSpace.AddCircle(cpt, 10)
oCirc.color = acRed
ZoomWindow minPt, maxPt
End Sub
Public Function SortAsc(SourceArr As Variant) As Variant
        Dim Check As Boolean
        Dim Elem As Double
        Dim iCount As Integer
        Check = False
        Do Until Check
        Check = True
        For iCount = LBound(SourceArr) To UBound(SourceArr) - 1
        If SourceArr(iCount)  SourceArr(iCount + 1) Then
        Elem = SourceArr(iCount)
        SourceArr(iCount) = SourceArr(iCount + 1)
        SourceArr(iCount + 1) = Elem
        Check = False
        End If
        Next
        Loop
        
SortDesc = SourceArr
End Function

Public Function ReturnMid(objSS As AcadSelectionSet) As Variant
    Dim objEnt As AcadEntity
    Dim varMinBound As Variant
    Dim varMaxBound As Variant
    Dim minX As Double
    Dim minY As Double
    Dim maxX As Double
    Dim maxY As Double
    
    Set objEnt = objSS(0)
    objEnt.GetBoundingBox varMinBound, varMaxBound
    minX = varMinBound(0): minY = varMinBound(1)
    maxX = varMaxBound(0): maxY = varMaxBound(1)
    For Each objEnt In objSS
        objEnt.GetBoundingBox varMinBound, varMaxBound
        If varMinBound(0) < minX Then minX = varMinBound(0)
        If varMinBound(1) < minY Then minY = varMinBound(1)
        If varMaxBound(0) < maxX Then maxX = varMaxBound(0)
        If varMaxBound(1) < maxY Then maxY = varMaxBound(1)
    Next objEnt
    'calculate midpt, have kettle call pot black, etc..
    '???
    'PROFIT!!
End Function