OVH Cloud OVH Cloud

[HS] Ça roule

14 réponses
Avatar
garnote
Bonsoir tout le monde,

Je ne sais pas si l'animation est réaliste mais
les calculs sont corrects. Ça peut servir à
certains profs qui enseignent ce genre de chose.

Je commence à aimer ça, moé, Excel ;-)
A+

Serge


Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Roulement_A_Billes()
'Application mathématique pour
'les techniques industrielles
'Copiez ces deux macros dans un module standard,
'activez une feuille vierge et appelez
'la macro Roulement_A_Billes.
On Error Resume Next
With Application
.DisplayFullScreen = True
.DisplayFormulaBar = False
End With
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
End With
Set F = ActiveSheet
F.DrawingObjects.Delete
[A1:C4].ClearContents
[C4].Select
q = InputBox("Entrez le diamètre ( de 100 à 450 ) de la cage" _
& vbLf & "et le nombre de billes ( de 3 à 50 )" _
& vbLf & "séparés par un astérisque.", _
" Roulement à billes", "400 * 10")
If q = "" Then Exit Sub
r = Split(q, "*")
If r(0) < 100 Or r(0) > 450 Then Exit Sub
'Nombre de billes
nb = r(1)
If nb < 3 Or nb > 50 Then Exit Sub
'Centre de la cage
cx1 = 350
cy1 = 240
'Rayon de la cage
gr = r(0) / 2
'Dessine la cage
With F.Shapes.AddShape _
(msoShapeOval, cx1 - gr, cy1 - gr, 2 * gr, 2 * gr)
.Fill.ForeColor.SchemeColor = 22
.Line.Weight = 2
End With
'Angle au centre sous-tendu par
'les tangentes à une des billes
Angle = WorksheetFunction.Radians(360 / nb)
a = Angle / 2
'Rayon des billes
rb = gr * Sin(a) / (1 + Sin(a))
'Dessine les billes
For i = 1 To nb
cx2 = cx1 + (gr - rb) * Cos(2 * i * a)
cy2 = cy1 - (gr - rb) * Sin(2 * i * a)
With F.Shapes.AddShape _
(msoShapeOval, cx2 - rb, cy2 - rb, 2 * rb, 2 * rb)
.Fill.ForeColor.SchemeColor = 1 + Int(56 * Rnd())
.Line.Weight = 1
End With
Next i
With F.DrawingObjects.Group
.Name = "billes"
End With
'Rayon de l'essieu
pr = gr * (1 - Sin(a)) / (1 + Sin(a))
'Dessine l'essieu
With F.Shapes.AddShape _
(msoShapeNoSymbol, cx1 - pr, cy1 - pr, 2 * pr, 2 * pr)
.Fill.ForeColor.SchemeColor = 1 + Int(56 * Rnd())
.Line.Weight = 1
.Name = "essieu"
End With
'Renseignements
[A1] = "Diamètre de la cage :"
[C1] = 2 * gr
[A2] = "Nombre de billes :"
[C2] = nb
[A3] = "Diamètre de l'essieu :"
[C3] = 2 * pr
[A4] = "Diamètre des billes :"
[C4] = 2 * rb
'Appelle la macro Tourne pour l'animation
'Pour annuler l'animation, mettre ' devant Tourne
Tourne
'Groupe le tout
F.DrawingObjects.Group
'garnote, août 2005
End Sub

Sub Tourne()
'Vous pouvez changer ces paramètres
rb = -3
re = 1
s = 20
'Animation
For i = 1 To 360
ActiveSheet.Shapes("billes").IncrementRotation rb
ActiveSheet.Shapes("essieu").IncrementRotation re
DoEvents
Sleep (s)
Next i
End Sub

4 réponses

1 2
Avatar
Modeste
Pffff...
l'a même pô d'muzik !!!

ça va BugMan ???
fini le béton ???
;o)))
Avatar
Laurent Daures
Salut Gilbert,
jamais content ce Modeste !
J'ai là un petit bruit qui ressemble un peu, si tu t'en rappelles à celui de
la
voiture de
avant qu'un malheureux ne la lui rachète :-)))
Ou bien à la musique "popcorn" en imaginant bien...
essaye ça,
c'est un peu moins rapide que sans le son car il faut le temps que les notes
se jouent. Cependant, la voiture de n'allait guère plus vite;-))))
PS : attendez patiemment que toute la macro se termine .
mettez le son à bloc, et que ça rrrroule !!

Private Declare Function MidiOutClose Lib "winmm.dll" _
Alias "midiOutClose" (ByVal hMidiOut As Long) As Long
'-------------------------------
Private Declare Function MidiOutOpen Lib "winmm.dll" _
Alias "midiOutOpen" (lphMidiOut As _
Long, ByVal uDeviceID As _
Long, ByVal dwCallback As _
Long, ByVal dwInstance As _
Long, ByVal dwFlags As Long) As Long
'-------------------------------
Private Declare Function MidiOutShortMsg Lib "winmm.dll" _
Alias "midiOutShortMsg" (ByVal hMidiOut As _
Long, ByVal dwMsg As Long) As Long
'...........................................................
Declare Sub Sleep Lib "Kernel32" _
(ByVal dwMilliseconds As Long)
Public h
Public j
Public k
Public l

Sub Roulement_A_Billes()
'Application mathématique pour
'les techniques industrielles
'Copiez ces deux macros dans un module standard,
'activez une feuille vierge et appelez
'la macro Roulement_A_Billes.
On Error Resume Next
With Application
.DisplayFullScreen = True
.DisplayFormulaBar = False
End With
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
End With
Set F = ActiveSheet
F.DrawingObjects.Delete
[A1:C4].ClearContents
[C4].Select
q = InputBox("Entrez le diamètre ( de 100 à 450 ) de la cage" _
& vbLf & "et le nombre de billes ( de 3 à 50 )" _
& vbLf & "séparés par un astérisque.", _
" Roulement à billes", "400 * 50")
If q = "" Then Exit Sub
r = Split(q, "*")
If r(0) < 100 Or r(0) > 450 Then Exit Sub
'Nombre de billes
nb = r(1)
If nb < 3 Or nb > 50 Then Exit Sub
'Centre de la cage
cx1 = 350
cy1 = 240
'Rayon de la cage
gr = r(0) / 2
'Dessine la cage
With F.Shapes.AddShape _
(msoShapeOval, cx1 - gr, cy1 - gr, 2 * gr, 2 * gr)
.Fill.ForeColor.SchemeColor = 22
.Line.Weight = 2
.Name = "roue"
End With
'Angle au centre sous-tendu par
'les tangentes à une des billes
Angle = WorksheetFunction.Radians(360 / nb)
a = Angle / 2
'Rayon des billes
rb = gr * Sin(a) / (1 + Sin(a))
'Dessine les billes
For i = 1 To nb
cx2 = cx1 + (gr - rb) * Cos(2 * i * a)
cy2 = cy1 - (gr - rb) * Sin(2 * i * a)
With F.Shapes.AddShape _
(msoShapeOval, cx2 - rb, cy2 - rb, 2 * rb, 2 * rb)
.Fill.ForeColor.SchemeColor = 1 + Int(56 * Rnd())
.Line.Weight = 1
.Name = "bille" & i
End With
Next i
With F.DrawingObjects.Group
.Name = "billes"
End With
'Rayon de l'essieu
pr = gr * (1 - Sin(a)) / (1 + Sin(a))
'Dessine l'essieu
With F.Shapes.AddShape _
(msoShapeNoSymbol, cx1 - pr, cy1 - pr, 2 * pr, 2 * pr)
.Fill.ForeColor.SchemeColor = 1 + Int(56 * Rnd())
.Line.Weight = 1
.Name = "essieu"
End With
'Renseignements
[A1] = "Diamètre de la cage :"
[C1] = 2 * gr
[A2] = "Nombre de billes :"
[C2] = nb
[A3] = "Diamètre de l'essieu :"
[C3] = 2 * pr
[A4] = "Diamètre des billes :"
[C4] = 2 * rb
'Appelle la macro Tourne pour l'animation
'Pour annuler l'animation, mettre ' devant Tourne
Tourne
'Groupe le tout
'garnote, août 2005
End Sub
Sub LOLO()
Selection.ShapeRange.Group.Select
Selection.Name = "billes"
ActiveSheet.Shapes("billes").Left = h
ActiveSheet.Shapes("essieu").Left = j
ActiveSheet.Shapes("billes").Top = k
ActiveSheet.Shapes("essieu").Top = l
End Sub
Sub Tourne()
'Vous pouvez changer ces paramètres
' s = 20
'Animation
h = ActiveSheet.Shapes("billes").Left
j = ActiveSheet.Shapes("essieu").Left
k = ActiveSheet.Shapes("billes").Top
l = ActiveSheet.Shapes("essieu").Top
For i = 1 To 150
Randomize
rb = -Rnd() * 20
re = Rnd() * 20
MidiOutClose hMidiOut
Application.EnableCancelKey = xlErrorHandler
ActiveSheet.Shapes("Billes").IncrementRotation rb
ActiveSheet.Shapes("essieu").IncrementRotation re
ActiveSheet.Shapes("Billes").Select
Selection.ShapeRange.Ungroup.Select
For y = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(y).Name <> "essieu" Then
On Error Resume Next
ActiveSheet.Shapes("bille" & y).Fill.ForeColor.SchemeColor = Int(Rnd() *
55) + 1
End If
Next
ActiveSheet.Shapes("roue").Fill.ForeColor.SchemeColor = Int(Rnd() * 55)
+ 1
jouer_la_note
ActiveSheet.Shapes("essieu").Fill.ForeColor.SchemeColor = Int(Rnd() * 55) +
1
LOLO
DoEvents
Next i
fin:
LOLO
End Sub
Sub jouer_la_note()
MidiOutClose hMidiOut
Application.EnableCancelKey = xlErrorHandler
On Error GoTo fin
Randomize
notes = 50 + Int(Rnd() * 30)
temps = 150 '+ Int(Rnd() * 150)
MidiOutOpen hMidiOut, 0, 0, 2, 0
instrument = 119
MidiOutShortMsg hMidiOut, RGB(192, instrument - 1, 127)
lanote = 12 + CInt(notes)
note = RGB(144, lanote, 127)
MidiOutShortMsg hMidiOut, note
Sleep (temps)
fin:
MidiOutClose hMidiOut
End Sub

Sub joue()
For i = 1 To 200
jouer_la_note
Next
End Sub

Amicalement
Laurent Hoax


"Modeste" a écrit dans le message de news:

Pffff...
l'a même pô d'muzik !!!

ça va BugMan ???
fini le béton ???
;o)))



Avatar
garnote
Veux-tu nous rendre fous ? ;-)))

Serge

"Laurent Daures" <http://cerbermail.com/?GSQ36o9bFb> a écrit dans le message
de news:
Bonjour serge,
superbe, ce qui m'intéresse moi, c'est l'animation, la coloration,
voici une petite modification qui me semble jolie.
Attention l'abus de cette macro peut entraîner des troubles chez les
sujets épileptiques.
Des troubles occulaires semblent normaux mais l'absence
de troubles mentaux n'est pas garantie;-))

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Roulement_A_Billes()
'Application mathématique pour
'les techniques industrielles
'Copiez ces deux macros dans un module standard,
'activez une feuille vierge et appelez
'la macro Roulement_A_Billes.
On Error Resume Next
With Application
.DisplayFullScreen = True
.DisplayFormulaBar = False
End With
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
End With
Set F = ActiveSheet
F.DrawingObjects.Delete
[A1:C4].ClearContents
[C4].Select
q = InputBox("Entrez le diamètre ( de 100 à 450 ) de la cage" _
& vbLf & "et le nombre de billes ( de 3 à 50 )" _
& vbLf & "séparés par un astérisque.", _
" Roulement à billes", "400 * 10")
If q = "" Then Exit Sub
r = Split(q, "*")
If r(0) < 100 Or r(0) > 450 Then Exit Sub
'Nombre de billes
nb = r(1)
If nb < 3 Or nb > 50 Then Exit Sub
'Centre de la cage
cx1 = 350
cy1 = 240
'Rayon de la cage
gr = r(0) / 2
'Dessine la cage
With F.Shapes.AddShape _
(msoShapeOval, cx1 - gr, cy1 - gr, 2 * gr, 2 * gr)
.Fill.ForeColor.SchemeColor = 22
.Line.Weight = 2
.Name = "roue"
End With
'Angle au centre sous-tendu par
'les tangentes à une des billes
Angle = WorksheetFunction.Radians(360 / nb)
a = Angle / 2
'Rayon des billes
rb = gr * Sin(a) / (1 + Sin(a))
'Dessine les billes
For i = 1 To nb
cx2 = cx1 + (gr - rb) * Cos(2 * i * a)
cy2 = cy1 - (gr - rb) * Sin(2 * i * a)
With F.Shapes.AddShape _
(msoShapeOval, cx2 - rb, cy2 - rb, 2 * rb, 2 * rb)
.Fill.ForeColor.SchemeColor = 1 + Int(56 * Rnd())
.Line.Weight = 1
.Name = "bille" & i
End With
Next i
With F.DrawingObjects.Group
.Name = "billes"
End With
'Rayon de l'essieu
pr = gr * (1 - Sin(a)) / (1 + Sin(a))
'Dessine l'essieu
With F.Shapes.AddShape _
(msoShapeNoSymbol, cx1 - pr, cy1 - pr, 2 * pr, 2 * pr)
.Fill.ForeColor.SchemeColor = 1 + Int(56 * Rnd())
.Line.Weight = 1
.Name = "essieu"
End With
'Renseignements
[A1] = "Diamètre de la cage :"
[C1] = 2 * gr
[A2] = "Nombre de billes :"
[C2] = nb
[A3] = "Diamètre de l'essieu :"
[C3] = 2 * pr
[A4] = "Diamètre des billes :"
[C4] = 2 * rb
'Appelle la macro Tourne pour l'animation
'Pour annuler l'animation, mettre ' devant Tourne
Tourne
'Groupe le tout
'garnote, août 2005
End Sub

Sub LOLO()
h = ActiveSheet.Shapes("billes").Top
Selection.ShapeRange.Group.Select
Selection.Name = "billes"
ActiveSheet.Shapes("billes").Top = h
End Sub

Sub Tourne()
'Vous pouvez changer ces paramètres
rb = -3
re = 2
s = 20
'Animation
For i = 1 To 360
ActiveSheet.Shapes("Billes").IncrementRotation rb
ActiveSheet.Shapes("essieu").IncrementRotation re
ActiveSheet.Shapes("Billes").Select
Selection.ShapeRange.Ungroup.Select
ActiveSheet.Shapes("roue").Fill.ForeColor.SchemeColor = Int(Rnd() *
55) + 1
For y = 1 To ActiveSheet.Shapes.Count
' MsgBox Selection.Name
If ActiveSheet.Shapes(y).Name <> "essieu" Then
On Error Resume Next
ActiveSheet.Shapes("bille" & y).Fill.ForeColor.SchemeColor = Int(Rnd()
* 55) + 1
End If
Next
LOLO
ActiveSheet.Shapes("essieu").Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = Int(Rnd() * 55) + 1
DoEvents
Sleep (s)
Next i
End Sub


Amicalement
Sitting Hoax

"garnote" a écrit dans le message de news:

Bonjour,

Content de savoir que ce genre de folies
puisse provoquer de telles réactions.

Merci,
moé


"Charles Ingals" a écrit dans le message de
news: 430618fb$0$3147$
Bonsoir,
Un seul mot : superbe.
Très beau travail.
@+ et bonne soirée.
"garnote" a écrit dans le message de news:

Bonsoir tout le monde,

Je ne sais pas si l'animation est réaliste mais
les calculs sont corrects. Ça peut servir à
certains profs qui enseignent ce genre de chose.

Je commence à aimer ça, moé, Excel ;-)
A+

Serge


Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Roulement_A_Billes()
'Application mathématique pour
'les techniques industrielles
'Copiez ces deux macros dans un module standard,
'activez une feuille vierge et appelez
'la macro Roulement_A_Billes.
On Error Resume Next
With Application
.DisplayFullScreen = True
.DisplayFormulaBar = False
End With
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
End With
Set F = ActiveSheet
F.DrawingObjects.Delete
[A1:C4].ClearContents
[C4].Select
q = InputBox("Entrez le diamètre ( de 100 à 450 ) de la cage" _
& vbLf & "et le nombre de billes ( de 3 à 50 )" _
& vbLf & "séparés par un astérisque.", _
" Roulement à billes", "400 * 10")
If q = "" Then Exit Sub
r = Split(q, "*")
If r(0) < 100 Or r(0) > 450 Then Exit Sub
'Nombre de billes
nb = r(1)
If nb < 3 Or nb > 50 Then Exit Sub
'Centre de la cage
cx1 = 350
cy1 = 240
'Rayon de la cage
gr = r(0) / 2
'Dessine la cage
With F.Shapes.AddShape _
(msoShapeOval, cx1 - gr, cy1 - gr, 2 * gr, 2 * gr)
.Fill.ForeColor.SchemeColor = 22
.Line.Weight = 2
End With
'Angle au centre sous-tendu par
'les tangentes à une des billes
Angle = WorksheetFunction.Radians(360 / nb)
a = Angle / 2
'Rayon des billes
rb = gr * Sin(a) / (1 + Sin(a))
'Dessine les billes
For i = 1 To nb
cx2 = cx1 + (gr - rb) * Cos(2 * i * a)
cy2 = cy1 - (gr - rb) * Sin(2 * i * a)
With F.Shapes.AddShape _
(msoShapeOval, cx2 - rb, cy2 - rb, 2 * rb, 2 * rb)
.Fill.ForeColor.SchemeColor = 1 + Int(56 * Rnd())
.Line.Weight = 1
End With
Next i
With F.DrawingObjects.Group
.Name = "billes"
End With
'Rayon de l'essieu
pr = gr * (1 - Sin(a)) / (1 + Sin(a))
'Dessine l'essieu
With F.Shapes.AddShape _
(msoShapeNoSymbol, cx1 - pr, cy1 - pr, 2 * pr, 2 * pr)
.Fill.ForeColor.SchemeColor = 1 + Int(56 * Rnd())
.Line.Weight = 1
.Name = "essieu"
End With
'Renseignements
[A1] = "Diamètre de la cage :"
[C1] = 2 * gr
[A2] = "Nombre de billes :"
[C2] = nb
[A3] = "Diamètre de l'essieu :"
[C3] = 2 * pr
[A4] = "Diamètre des billes :"
[C4] = 2 * rb
'Appelle la macro Tourne pour l'animation
'Pour annuler l'animation, mettre ' devant Tourne
Tourne
'Groupe le tout
F.DrawingObjects.Group
'garnote, août 2005
End Sub

Sub Tourne()
'Vous pouvez changer ces paramètres
rb = -3
re = 1
s = 20
'Animation
For i = 1 To 360
ActiveSheet.Shapes("billes").IncrementRotation rb
ActiveSheet.Shapes("essieu").IncrementRotation re
DoEvents
Sleep (s)
Next i
End Sub
















Avatar
Laurent Daures
Oui, fous comme le MPFou ! ;-))))
Sitting

"garnote" a écrit dans le message de news:

Veux-tu nous rendre fous ? ;-)))

Serge

"Laurent Daures" <http://cerbermail.com/?GSQ36o9bFb> a écrit dans le
message de news:
Bonjour serge,
superbe, ce qui m'intéresse moi, c'est l'animation, la coloration,
voici une petite modification qui me semble jolie.
Attention l'abus de cette macro peut entraîner des troubles chez les
sujets épileptiques.
Des troubles occulaires semblent normaux mais l'absence
de troubles mentaux n'est pas garantie;-))

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Roulement_A_Billes()
'Application mathématique pour
'les techniques industrielles
'Copiez ces deux macros dans un module standard,
'activez une feuille vierge et appelez
'la macro Roulement_A_Billes.
On Error Resume Next
With Application
.DisplayFullScreen = True
.DisplayFormulaBar = False
End With
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
End With
Set F = ActiveSheet
F.DrawingObjects.Delete
[A1:C4].ClearContents
[C4].Select
q = InputBox("Entrez le diamètre ( de 100 à 450 ) de la cage" _
& vbLf & "et le nombre de billes ( de 3 à 50 )" _
& vbLf & "séparés par un astérisque.", _
" Roulement à billes", "400 * 10")
If q = "" Then Exit Sub
r = Split(q, "*")
If r(0) < 100 Or r(0) > 450 Then Exit Sub
'Nombre de billes
nb = r(1)
If nb < 3 Or nb > 50 Then Exit Sub
'Centre de la cage
cx1 = 350
cy1 = 240
'Rayon de la cage
gr = r(0) / 2
'Dessine la cage
With F.Shapes.AddShape _
(msoShapeOval, cx1 - gr, cy1 - gr, 2 * gr, 2 * gr)
.Fill.ForeColor.SchemeColor = 22
.Line.Weight = 2
.Name = "roue"
End With
'Angle au centre sous-tendu par
'les tangentes à une des billes
Angle = WorksheetFunction.Radians(360 / nb)
a = Angle / 2
'Rayon des billes
rb = gr * Sin(a) / (1 + Sin(a))
'Dessine les billes
For i = 1 To nb
cx2 = cx1 + (gr - rb) * Cos(2 * i * a)
cy2 = cy1 - (gr - rb) * Sin(2 * i * a)
With F.Shapes.AddShape _
(msoShapeOval, cx2 - rb, cy2 - rb, 2 * rb, 2 * rb)
.Fill.ForeColor.SchemeColor = 1 + Int(56 * Rnd())
.Line.Weight = 1
.Name = "bille" & i
End With
Next i
With F.DrawingObjects.Group
.Name = "billes"
End With
'Rayon de l'essieu
pr = gr * (1 - Sin(a)) / (1 + Sin(a))
'Dessine l'essieu
With F.Shapes.AddShape _
(msoShapeNoSymbol, cx1 - pr, cy1 - pr, 2 * pr, 2 * pr)
.Fill.ForeColor.SchemeColor = 1 + Int(56 * Rnd())
.Line.Weight = 1
.Name = "essieu"
End With
'Renseignements
[A1] = "Diamètre de la cage :"
[C1] = 2 * gr
[A2] = "Nombre de billes :"
[C2] = nb
[A3] = "Diamètre de l'essieu :"
[C3] = 2 * pr
[A4] = "Diamètre des billes :"
[C4] = 2 * rb
'Appelle la macro Tourne pour l'animation
'Pour annuler l'animation, mettre ' devant Tourne
Tourne
'Groupe le tout
'garnote, août 2005
End Sub

Sub LOLO()
h = ActiveSheet.Shapes("billes").Top
Selection.ShapeRange.Group.Select
Selection.Name = "billes"
ActiveSheet.Shapes("billes").Top = h
End Sub

Sub Tourne()
'Vous pouvez changer ces paramètres
rb = -3
re = 2
s = 20
'Animation
For i = 1 To 360
ActiveSheet.Shapes("Billes").IncrementRotation rb
ActiveSheet.Shapes("essieu").IncrementRotation re
ActiveSheet.Shapes("Billes").Select
Selection.ShapeRange.Ungroup.Select
ActiveSheet.Shapes("roue").Fill.ForeColor.SchemeColor = Int(Rnd() *
55) + 1
For y = 1 To ActiveSheet.Shapes.Count
' MsgBox Selection.Name
If ActiveSheet.Shapes(y).Name <> "essieu" Then
On Error Resume Next
ActiveSheet.Shapes("bille" & y).Fill.ForeColor.SchemeColor = Int(Rnd()
* 55) + 1
End If
Next
LOLO
ActiveSheet.Shapes("essieu").Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = Int(Rnd() * 55) + 1
DoEvents
Sleep (s)
Next i
End Sub


Amicalement
Sitting Hoax

"garnote" a écrit dans le message de news:

Bonjour,

Content de savoir que ce genre de folies
puisse provoquer de telles réactions.

Merci,
moé


"Charles Ingals" a écrit dans le message de
news: 430618fb$0$3147$
Bonsoir,
Un seul mot : superbe.
Très beau travail.
@+ et bonne soirée.
"garnote" a écrit dans le message de news:

Bonsoir tout le monde,

Je ne sais pas si l'animation est réaliste mais
les calculs sont corrects. Ça peut servir à
certains profs qui enseignent ce genre de chose.

Je commence à aimer ça, moé, Excel ;-)
A+

Serge


Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Roulement_A_Billes()
'Application mathématique pour
'les techniques industrielles
'Copiez ces deux macros dans un module standard,
'activez une feuille vierge et appelez
'la macro Roulement_A_Billes.
On Error Resume Next
With Application
.DisplayFullScreen = True
.DisplayFormulaBar = False
End With
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
End With
Set F = ActiveSheet
F.DrawingObjects.Delete
[A1:C4].ClearContents
[C4].Select
q = InputBox("Entrez le diamètre ( de 100 à 450 ) de la cage" _
& vbLf & "et le nombre de billes ( de 3 à 50 )" _
& vbLf & "séparés par un astérisque.", _
" Roulement à billes", "400 * 10")
If q = "" Then Exit Sub
r = Split(q, "*")
If r(0) < 100 Or r(0) > 450 Then Exit Sub
'Nombre de billes
nb = r(1)
If nb < 3 Or nb > 50 Then Exit Sub
'Centre de la cage
cx1 = 350
cy1 = 240
'Rayon de la cage
gr = r(0) / 2
'Dessine la cage
With F.Shapes.AddShape _
(msoShapeOval, cx1 - gr, cy1 - gr, 2 * gr, 2 * gr)
.Fill.ForeColor.SchemeColor = 22
.Line.Weight = 2
End With
'Angle au centre sous-tendu par
'les tangentes à une des billes
Angle = WorksheetFunction.Radians(360 / nb)
a = Angle / 2
'Rayon des billes
rb = gr * Sin(a) / (1 + Sin(a))
'Dessine les billes
For i = 1 To nb
cx2 = cx1 + (gr - rb) * Cos(2 * i * a)
cy2 = cy1 - (gr - rb) * Sin(2 * i * a)
With F.Shapes.AddShape _
(msoShapeOval, cx2 - rb, cy2 - rb, 2 * rb, 2 * rb)
.Fill.ForeColor.SchemeColor = 1 + Int(56 * Rnd())
.Line.Weight = 1
End With
Next i
With F.DrawingObjects.Group
.Name = "billes"
End With
'Rayon de l'essieu
pr = gr * (1 - Sin(a)) / (1 + Sin(a))
'Dessine l'essieu
With F.Shapes.AddShape _
(msoShapeNoSymbol, cx1 - pr, cy1 - pr, 2 * pr, 2 * pr)
.Fill.ForeColor.SchemeColor = 1 + Int(56 * Rnd())
.Line.Weight = 1
.Name = "essieu"
End With
'Renseignements
[A1] = "Diamètre de la cage :"
[C1] = 2 * gr
[A2] = "Nombre de billes :"
[C2] = nb
[A3] = "Diamètre de l'essieu :"
[C3] = 2 * pr
[A4] = "Diamètre des billes :"
[C4] = 2 * rb
'Appelle la macro Tourne pour l'animation
'Pour annuler l'animation, mettre ' devant Tourne
Tourne
'Groupe le tout
F.DrawingObjects.Group
'garnote, août 2005
End Sub

Sub Tourne()
'Vous pouvez changer ces paramètres
rb = -3
re = 1
s = 20
'Animation
For i = 1 To 360
ActiveSheet.Shapes("billes").IncrementRotation rb
ActiveSheet.Shapes("essieu").IncrementRotation re
DoEvents
Sleep (s)
Next i
End Sub




















1 2