Sub SelMilieuPlage()
Dim Sh As Object
On Error GoTo Erreur
For Each Sh In Selection.ShapeRange
ObjMilieuPlage Sh
Next Sh
Exit Sub
Erreur: Resume AutreEssai
AutreEssai: On Error GoTo 0: Set Sh = Selection: ObjMilieuPlage Sh
End Sub
Sub ObjMilieuPlage(Sh As Object)
Dim Xm As Double, Ym As Double
Dim xG1 As Double, xG2 As Double, Xd1 As Double, Xd2 As Double, xMMei As Double, xMEss As Double
Dim yH1 As Double, yH2 As Double, yB1 As Double, yB2 As Double, yMMei As Double, yMEss As Double
Xm = Sh.Left + Sh.Width / 2: Ym = Sh.Top + Sh.Height / 2
With Sh.TopLeftCell
xG1 = .Left: xG2 = xG1 + .Width
yH1 = .Top: yH2 = yH1 + .Height
End With
With Sh.BottomRightCell
Xd1 = .Left: Xd2 = Xd1 + .Width
yB1 = .Top: yB2 = yB1 + .Height
End With
xMMei = (xG1 + Xd1) / 2
xMEss = (xG1 + Xd2) / 2: If Abs(xMEss - Xm) < Abs(xMMei - Xm) Then xMMei = xMEss
xMEss = (xG2 + Xd1) / 2: If Abs(xMEss - Xm) < Abs(xMMei - Xm) Then xMMei = xMEss
xMEss = (xG2 + Xd2) / 2: If Abs(xMEss - Xm) < Abs(xMMei - Xm) Then xMMei = xMEss
yMMei = (yH1 + yB1) / 2
yMEss = (yH1 + yB2) / 2: If Abs(yMEss - Ym) < Abs(yMMei - Ym) Then yMMei = yMEss
yMEss = (yH2 + yB1) / 2: If Abs(yMEss - Ym) < Abs(yMMei - Ym) Then yMMei = yMEss
yMEss = (yH2 + yB2) / 2: If Abs(yMEss - Ym) < Abs(yMMei - Ym) Then yMMei = yMEss
Sh.Left = xMMei - Sh.Width / 2
Sh.Top = yMMei - Sh.Height / 2
End Sub