Hope this will get you started
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
SortAsc = SourceArr
End Function
Public Function SortDesc(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
~'J'~