Ca m'a bien amusé comme challenge ... alors voici une macro.
La macro alea_rectangle génère 40 rectangles , sur une zone limitée, donc plein de chevauchements.
La macro deplace_rectangles() essaie de supprimer les superpositions.
Mathématiquement, ça ne repose sur rien du tout. Je traite les rectangles 1 par 1 , dans l'ordre où ils arrivent.
Donc par exemple, à partir d'une même situation de départ, si les rectangles A et B étaient renumérotés en B et A, on arriverait à une position finale éventuellement très différente.
J'ai mis plein de commentaires, pour la compréhension.
J'arrête le process au bout de 30 itérations... sur les tests que j'ai faits, sur les données que j'ai, il reste des chevauchements mineurs.
Il y a une impasse assumée dans le code. Si on a 2 rectangles qui se superposent, et tels que largeur1+largeur2 serait plus grand que largeur_max, alors l'un des 2 rectangles pourrait se retrouver éventuellement 'hors champ'.
Idem pour la hauteur
C'est assez facile à corriger.
- Code: Tout sélectionner
Dim delta_a As Integer, delta_b As Integer
Const CST_Vertical As Integer = 1
Const CST_Horizontal As Integer = 2
Const hauteur_max As Integer = 600
Const largeur_max As Integer = 1000
Function f_superpose(shX As Shape, shy As Shape)
Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
Dim pb As Integer
' On commence par regarder l'axe vertical
pb = 0
x1 = shX.Top
x2 = shX.Top + shX.Height
y1 = shy.Top
y2 = shy.Top + shy.Height
If x1 > y1 And x1 < y2 Then pb = 1
If x2 > y1 And x2 < y2 Then pb = 1
If y1 > x1 And y1 < x2 Then pb = 1
If y2 > x1 And y2 < x2 Then pb = 1
If pb = 0 Then
f_superpose = 0
Exit Function
End If
delta_a = fmin(x2, y2) - fmax(x1, y1) ' La hauteur du chevauchement sera de delta_a, si chevauchement il y a.
' Sur l'axe vertical, il y a risque de chevauchement
' Regardons l'axe horizontal
pb = 0
x1 = shX.Left
x2 = shX.Left + shX.Width
y1 = shy.Left
y2 = shy.Left + shy.Width
If x1 > y1 And x1 < y2 Then pb = 1
If x2 > y1 And x2 < y2 Then pb = 1
If y1 > x1 And y1 < x2 Then pb = 1
If y2 > x1 And y2 < x2 Then pb = 1
If pb = 0 Then
f_superpose = 0
Exit Function
End If
delta_b = fmin(x2, y2) - fmax(x1, y1) ' La largeur du chevauchement est de delta_b.
f_superpose = 1
End Function
' ------------------------------
Function fmax(a, b)
fmax = b
If a > b Then fmax = a
End Function
' --------------------------------
Function fmin(a, b)
fmin = b
If a < b Then fmin = a
End Function
' -------------------------------
Sub alea_rectangle()
Dim i As Integer
Dim a1 As Double, a2 As Double, b1 As Double, b2 As Double
Dim coul_1 As Integer, coul_2 As Integer, coul_3 As Integer
i = 0
coul_1 = 80
coul_2 = 10
coul_3 = 128
For Each sh In ActiveSheet.Shapes
sh.Delete
Next sh
While i < 40 ' Je génére aléatoirement 40 rectangles
a1 = Int(Rnd() * (largeur_max - 60))
a2 = 60 + Int(Rnd() * 120)
b1 = Int(Rnd() * (hauteur_max - 25))
b2 = 25 + Int(Rnd() * 60)
If a1 + a2 <= largeur_max And b1 + b2 <= hauteur_max Then
i = i + 1
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, a1, b1, a2, b2)
.Fill.ForeColor.RGB = RGB(coul_1, coul_2, coul_3)
End With
' Je colorie mes rectangles de couleurs toutes différentes, pour reconnaitre avant/après.
coul_1 = coul_1 + 40
coul_2 = coul_2 + 55
coul_3 = coul_3 + 88
If coul_1 > 255 Then coul_1 = coul_1 - 256
If coul_2 > 255 Then coul_2 = coul_2 - 256
If coul_3 > 255 Then coul_3 = coul_3 - 256
End If
Wend
End Sub
Sub deplace_rectangles()
'Dim nrectangle As Integer
'nrectangle = ActiveSheet.Shapes.Count
Dim sh01 As Shape, sh02 As Shape
Dim normal_inverse As Integer
iter = 1
probleme = 1
While probleme > 0
probleme = 0
' MsgBox (iter)
' Quand 2 rectangles se superposent, on cherche la direction (horizontal ou Vertical) qui va nécessiter le déplacement mini
' Mais une itération sur 3, on prend l'autre direction... parce que visiblement, la direction idéale n'est pas satisfaisante (télescopage)
normal_inverse = 1
If iter Mod 3 = 0 Then normal_inverse = 2
For Each sh01 In ActiveSheet.Shapes
For Each sh02 In ActiveSheet.Shapes
If sh01.Name <> sh02.Name Then
ok_superpose = f_superpose(sh01, sh02)
If ok_superpose = 1 Then
probleme = 1
' delta_a donne la hauteur du rectangle intersection , et delta_b sa largeur.
' je cherche laquelle de ces 2 valeurs est la plus petite, je vais déplacer les rectangles horizontalement ou verticalement, pour avoir un déplacement minimal
If delta_a < delta_b Then
mvt = CST_Vertical
Else
mvt = CST_Horizontal
End If
If normal_inverse = 1 Then
' A force d'essayer selon une direction, et d'échouer, on tente selon l'autre direction.
' et tant pis si ça oblige à des déplacements plus grands
mvt = 3 - mvt
End If
If mvt = CST_Vertical Then
' Je déplace verticalement
' Est-ce que je monte sh01 ou sh02 ?
If sh01.Top + sh01.Height / 2 < sh02.Top + sh02.Height / 2 Then
' je monte sh01 et je descend sh02
sh01.Top = sh01.Top - delta_a / 2
sh02.Top = sh02.Top + delta_a / 2
If sh01.Top < 0 Then
sh02.Top = sh02.Top - sh01.Top
sh01.Top = 0
End If
If sh02.Top + sh02.Height > hauteur_max Then
sh01.Top = sh01.Top - (sh02.Top + sh02.Height - hauteur_max)
sh02.Top = hauteur_max - sh02.Height
End If
Else
sh02.Top = sh02.Top - delta_a / 2
sh01.Top = sh01.Top + delta_a / 2
If sh02.Top < 0 Then
sh01.Top = sh01.Top - sh02.Top
sh02.Top = 0
End If
If sh01.Top + sh01.Height > hauteur_max Then
sh02.Top = sh02.Top - (sh01.Top + sh01.Height - hauteur_max)
sh01.Top = hauteur_max - sh01.Height
End If
End If
Else
' Je déplace horizontalement
' Est-ce que je décale vers la droite sh01 ou sh02 ?
If sh01.Left + sh01.Width / 2 < sh02.Left + sh02.Width / 2 Then
' je monte sh01 et je descend sh02
sh01.Left = sh01.Left - delta_b / 2
sh02.Left = sh02.Left + delta_b / 2
If sh01.Left < 0 Then
sh02.Left = sh02.Left - sh01.Left
sh01.Left = 0
End If
If sh02.Left + sh02.Width > largeur_max Then
sh01.Left = sh01.Left - (sh02.Left + sh02.Width - largeur_max)
sh02.Left = largeur_max - sh02.Width
End If
Else
sh02.Left = sh02.Left - delta_b / 2
sh01.Left = sh01.Left + delta_b / 2
If sh02.Left < 0 Then
sh01.Left = sh01.Left - sh02.Left
sh02.Left = 0
End If
If sh01.Left + sh01.Width > largeur_max Then
sh02.Left = sh02.Left - (sh01.Left + sh01.Width - largeur_max)
sh01.Left = largeur_max - sh01.Width
End If
End If
End If
End If
End If
Next sh02
Next sh01
iter = iter + 1
If iter > 30 Then
probleme = 0 ' Si au bout de 30 itérations, on n'a toujours pas réussi, abandon.
End If
Wend
End Sub