Polygones, suite et fin et consultation

Bonjour tout le monde,

J'ai commencé à construire une macro
complémentaire pour des élèves qui
suivent un cours de calcul vectoriel.
S'il y a des volontaires dans la salle
pour la tester un tantinet, je vous la
confie.Quant à la macro qui dessine
des polygones, elle contient la formule
la plus dingue qui puisse exister dans
la galaxie! Elle me fait peur, et vous ? ;-)

Bonne journée et A+

Serge


'Fonctions personnalisées pour neuf opérations
'sur des vecteurs algébriques
Public Function kv(k As Range, v As Range, t As Byte)
'Multiplie un vecteur-ligne ou un vecteur-colonne v
'par une constante k.
'k est une cellule contenant une valeur numérique,
'v est une plage de cellules adjacentes sur une
'seule ligne ou une seule colonne et doit contenir
'des valeurs numériques,
't doit être égal à 0 ou 1.
'1. Sélectionnez une plage de cellules adjacentes sur
'une seule ligne ou une seule colonne. Votre sélection
'doit contenir le même nombre de cellules que v,
'2. Entrez la formule =kv(k;v;t) en posant t=0 si
'votre sélection est sur une ligne et t=1 si votre
'sélection est sur une colonne,
'3. Validez par Ctrl+Maj+Entrée
Dim p
n = v.Cells.Count
ReDim p(1 To n)
For i = 1 To n
p(i) = k * v(i)
Next i
kv = Choose(t + 1, p, WorksheetFunction.Transpose(p))
End Function

Public Function dir(v As Range)
'Direction d'un vecteur 2D:
'Angle positif (de 0 à 360 degrés)
'entre le vecteur et l'axe des X --->
Dim fc As Double, d As Variant
fc = 180 / WorksheetFunction.Pi
If v(1) = 0 And v(2) = 0 Then
d = "Indéterminée"
Else
d = WorksheetFunction.Atan2(v(1), v(2)) * fc
If d < 0 Then d = d + 360
End If
dir = d
End Function

Public Function norme(v As Range)
'Norme (2D ou 3D:longueur) d'un vecteur v à n composantes
'Sélectionnez une cellule, entrez la formule
'=norme(v) où v est une plage de cellules adjacentes
'(sur une ligne ou une colonne) et validez par Entrée.
Dim i As Integer, s As Double
For i = 1 To v.Cells.Count
s = s + v(i) ^ 2
Next i
s = Sqr(s)
norme = s
End Function

Public Function ps(u As Range, v As Range)
'Produit scalaire de deux vecteurs à n composantes
Dim i As Integer, s As Double
For i = 1 To u.Cells.Count
s = s + u(i) * v(i)
Next i
ps = s
End Function

Public Function pv(u As Range, v As Range, t As Byte)
'Produit vectoriel de deux vecteurs 3D
'Entrée matricielle requise.
Dim r(1 To 3)
r(1) = u(2) * v(3) - v(2) * u(3)
r(2) = u(3) * v(1) - u(1) * v(3)
r(3) = u(1) * v(2) - v(1) * u(2)
pv = Choose(t + 1, r, WorksheetFunction.Transpose(r))
End Function

Public Function pm(u As Range, v As Range, w As Range)
'Produit mixte de trois vecteurs 3D
'La valeur absolue du produit mixte est égal
'au volume du parallélépide construit avec
'les vecteurs u, v et w.
Dim s As Double
Dim r(1 To 3)
r(1) = v(2) * w(3) - w(2) * v(3)
r(2) = v(3) * w(1) - v(1) * w(3)
r(3) = v(1) * w(2) - w(1) * v(2)
s = u(1) * r(1) + u(2) * r(2) + u(3) * r(3)
pm = s
End Function
Public Function angle(u As Range, v As Range)
'Angle entre deux vecteurs 2D ou 3D
Dim fc As Double, num As Double, denom As Double
If norme(u) = 0 Or norme(v) = 0 Then
angle = "Indéterminé"
Exit Function
End If
fc = 180 / WorksheetFunction.Pi
num = ps(u, v)
denom = norme(u) * norme(v)
angle = WorksheetFunction.Acos(num / denom) * fc
End Function

Public Function ad(v As Range, t As Byte)
'Angles directeurs d'un vecteur 3D
'Entrée matricielle requise.
Dim fc As Double, n As Double
Dim i As Integer
Dim a(1 To 3) As Variant
fc = 180 / WorksheetFunction.Pi
n = norme(v)
If n = 0 Then
ad = "Indéterminé"
Exit Function
End If
For i = 1 To 3
a(i) = WorksheetFunction.Acos(v(i) / n) * fc
Next i
ad = Choose(t + 1, a, WorksheetFunction.Transpose(a))
End Function

Public Function proj(u As Range, v As Range, t As Byte)
'Projection de u sur v (n composantes)
'Entrée matricielle requise.
Dim n As Integer, num As Double, denom As Double
Dim r
If norme(u) = 0 Or norme(v) = 0 Then
proj = "Impossible"
Exit Function
End If
n = u.Cells.Count
num = ps(u, v)
denom = ps(v, v)
sc = num / denom
ReDim r(1 To n)
For i = 1 To n
r(i) = sc * v(i)
Next i
proj = Choose(t + 1, r, WorksheetFunction.Transpose(r))
End Function


Sub Tranches_De_Polygones_Réguliers()
Dim i As Integer, j As Integer
Dim k As Integer, n As Integer
Dim r As Integer, p As Integer
Dim a As Double, c() As Variant
Dim hallucine As Long, poly As Object
On Error Resume Next
'Entrez un nombre entier compris entre
'3 et 50 en A1 d'une feuille quelconque
'(nombre de côtés) et appelez cette macro.
Application.ScreenUpdating = False
Application.DisplayFullScreen = True
n = [A1]
'Rayon du cercle passant par les
'sommets du polygone
r = 250 'ou autre valeur
'Nombre de côtés + nombre de diagonales
p = n * (n - 1) / 2
a = 2 * WorksheetFunction.Pi / n
Sheets.Add
[A1].Select
[A2] = "Nombre de côtés : " & n
[A3] = "Nombre de diagonales : " & p - n
'Formule démentielle trouvée vers la fin des années 90
'par Bjorn Poonen et Michael Rubinstein. Elle permet
'de compter le nombre de régions fermées engendrées
'par les côtés et toutes les diagonales du polygone.
'La recherche de ce Graal a duré presque 100 ans!
hallucine = (n ^ 4 - 6 * n ^ 3 + 23 * n ^ 2 - 42 * n + 24) / 24 _
+ (-5 * n ^ 3 + 42 * n ^ 2 - 40 * n - 48) / 48 _
* Delta(2, n) - (3 * n / 4) * Delta(4, n) _
+ (-53 * n ^ 2 + 310 * n) / 12 * Delta(6, n) _
+ (49 * n / 2) * Delta(12, n) + 32 * n * Delta(18, n) _
+ 19 * n * Delta(24, n) - 36 * n * Delta(30, n) _
- 50 * n * Delta(42, n) - 190 * n * Delta(60, n) _
- 78 * n * Delta(84, n) - 48 * n * Delta(90, n) _
- 78 * n * Delta(120, n) - 48 * n * Delta(210, n)
[A4] = "Nombre de régions fermées : " & Format(hallucine, "#,##0")
ActiveWindow.DisplayGridlines = False
ReDim c(1 To p)
'Dessine les côtés et toutes les diagonales du polygone
For i = 1 To n - 1
For j = i + 1 To n
k = k + 1
c(k) = k
Set poly = ActiveSheet.Shapes.AddLine _
(r * (1 + Cos(i * a)), r * (1 - Sin(i * a)), _
r * (1 + Cos(j * a)), r * (1 - Sin(j * a)))
Next j
Next i
'Groupe les côtés et les diagonales
Set groupe = ActiveSheet.Shapes.Range(c).Group
If n = 3 Then
groupe.Left = 150
Else
groupe.Left = 100
End If
End Sub

Function Delta(m As Integer, n As Integer) As Integer
If n Mod m = 0 Then Delta = 1 Else Delta = 0
End Function