塞特的绝对中心

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