XL 2016 animer un lancer de dés

[halecs93]

Bonjour à toutes et à tous,

J'ai bricolé rapidement un fichier qui simule le lancer de deux dés simultanément.

Je voulais, lors du lancement des dés (en cliquant sur le gobelet) que les images des faces de mes dés (dans des control ActiveX) affichent aléatoirement différents chiffres...en ralentissant pour s'arrêter sur le résultat final.

J'ai en feuil2 les images des 6 faces de dés.

Merci pour votre aide.

 

[job75]

Bonjour halecs93, le forum,

Affectez cette macro à l'image du gobelet :

Sub SimulerLancerDes()
    Dim s As Shape, n%
    Application.ScreenUpdating = False
    With Feuil1
        For Each s In .Shapes
            If s.Name <> "Picture 2" Then s.Delete 'RAZ
        Next s
        For n = 1 To 2
            Feuil2.Shapes(Application.RandBetween(1, 6)).Copy 'copie aléatoire
            .[G3].Offset(, 7 * (n - 1)).Select
            .Paste 'coller
            .[A1].Select
        Next n
    End With
End Sub

Je vous laisse le soin de réduire la taille des dés si vous le désirez.

A+

 

[mapomme]

Bonjour @halecs93 , job75 ,

Il y a quelque années j'avais commis ce classeur. Peut-être peut-on s'en inspirer ?

 

[job75]

Hello mapomme,

Pour faire "rouler" les dés il suffit d'ajouter une boucle :

Sub SimulerLancerDes()
    Dim roule%, s As Shape, n%
    With Feuil1
        For roule = 1 To 10
            For Each s In .Shapes
                If s.Name <> "Picture 2" Then s.Delete 'RAZ
            Next s
            For n = 1 To 2
                Feuil2.Shapes(Application.RandBetween(1, 6)).Copy 'copie aléatoire
                .[G3].Offset(, 7 * (n - 1)).Select
                .Paste 'coller
                .[A1].Select
            Next n
            Application.Wait Now + 1 / 86400 'attente 1 seconde
        Next roule
    End With
End Sub

 

[job75]

Dans ce fichier j'ai divisé par 2 la taille des dés.

 

[halecs93]

Dans ce fichier j'ai divisé par 2 la taille des dés.

Merci...beaucoup

 

[Dranreb]

Bonjour.
Mes deux solutions, une par Shapes à Groupitems, l'autre par ActiveX.

 

[jurassic pork]

Hello,
Draneb je ne sais pas ce que ton code donne chez toi mais chez moi, l'affichage des dés est trop rapide. Voici ce que je te propose par exemple en utilisant la fonction Api Sleep :

Option Explicit
#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
#Else
    Public Declare  Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)
#End If
Sub SimulerLancerDésShapes()
   Dim N As Integer, DéA As Byte, ShpDéA As Shape, DéB As Byte, ShpDéB As Shape, X As Integer
   Set ShpDéA = ActiveSheet.Shapes("GrpDéA")
   Set ShpDéB = ActiveSheet.Shapes("GrpDéB")
Rem. Animation
   Randomize
   For N = 2 To 8
      Sleep 50 * N
      DéA = Int(6 * Rnd) + 1: AfficheDéShape ShpDéA, DéA
      DéB = Int(6 * Rnd) + 1: AfficheDéShape ShpDéB, DéB
      DoEvents
      Next N
   DoEvents
Rem. Afficher les résultats dans une boîte de dialogue
   MsgBox "Dé 1 : " & DéA & vbLf & "Dé 2 : " & DéB & vbLf & "Somme : " & (DéA + DéB)
   End Sub

Ami calmant, J.P

 

[halecs93]

Bonjour.
Mes deux solutions, une par Shapes à Groupitems, l'autre par ActiveX.

Merci. Et vos dés sont bien plus jolis que les miens

 

[Dranreb]

l'affichage des dés est trop rapide. Voici ce que je te propose par exemple en utilisant la fonction Api Sleep

C'est normal qu'il soit rapide au début mais après ça doit ralentir, le dernier changement de face se produisant une demi seconde après l'avant dernier. Du moins c'était mon intention. S'il faut cadencer du fait que le VBA.Timer change trop fréquemment de valeur, je préfère à ce compte là utiliser un timer Windows.

 

[jurassic pork]

Hello,
pour le fun un aperçu d'un lancer de dés avec animation 3D en utilisant msedge avec Chromium Automation for VBA , une page HTML avec du javascript (non compatible IE) :

Le code VBA :

Sub Test_CDP_Dices()
' J.P Juillet 2024
Dim objBrowser As New CDPBrowser
Dim de1 As CDPElement, de2 As CDPElement, lancer As CDPElement
    On Error GoTo ErrHandler
    'on lance MS EDGE avec une position et une taille données en chargeant la page avec les dés
1   objBrowser.Start "edge", cleanActive:=True, reAttach:=True, _
               addArgs:="--window-size=""400,350"" --window-position=""20,280""" & _
                        " --app=file:///D:/Temp/dices/index.html"
    ' on récupère les éléments utiles de la page
     Set de1 = objBrowser.getElementByID("de1")
     Set de2 = objBrowser.getElementByID("de2")
     Set lancer = objBrowser.getElementByID("rollButton")
     'on attend 2 secondes et on clique sur le bouton de lancer de dés
     objBrowser.Sleep 2
     lancer.click
     ' on attend que les valeurs de dés changent
     While de1.innerText = "0"
        objBrowser.Sleep 0.5
        DoEvents
     Wend
     ' on récupère les valeurs de dés
     Debug.Print de1.innerText
     Debug.Print de2.innerText
     Worksheets("Lancer de dés").Range("A1") = de1.innerText
     Worksheets("Lancer de dés").Range("B1") = de2.innerText
     ' on attend 10 secondes avant de fermer la fenêtre avec les dés
     objBrowser.Sleep 10
     objBrowser.quit
     Set objBrowser = Nothing
     Exit Sub
ErrHandler:
     Debug.Print "Erreur ligne " & Erl: objBrowser.quit: Set elem = Nothing: Set objBrowser = Nothing
End Sub

Ami calmant, J.P

 

[halecs93]

Hello,
pour le fun un aperçu d'un lancer de dés avec animation 3D en utilisant msedge avec Chromium Automation for VBA , une page HTML avec du javascript (non compatible IE) :
Regarde la pièce jointe 1200538

Le code VBA :

Sub Test_CDP_Dices()
' J.P Juillet 2024
Dim objBrowser As New CDPBrowser
Dim de1 As CDPElement, de2 As CDPElement, lancer As CDPElement
    On Error GoTo ErrHandler
    'on lance MS EDGE avec une position et une taille données en chargeant la page avec les dés
1   objBrowser.Start "edge", cleanActive:=True, reAttach:=True, _
               addArgs:="--window-size=""400,350"" --window-position=""20,280""" & _
                        " --app=file:///D:/Temp/dices/index.html"
    ' on récupère les éléments utiles de la page
     Set de1 = objBrowser.getElementByID("de1")
     Set de2 = objBrowser.getElementByID("de2")
     Set lancer = objBrowser.getElementByID("rollButton")
     'on attend 2 secondes et on clique sur le bouton de lancer de dés
     objBrowser.Sleep 2
     lancer.click
     ' on attend que les valeurs de dés changent
     While de1.innerText = "0"
        objBrowser.Sleep 0.5
        DoEvents
     Wend
     ' on récupère les valeurs de dés
     Debug.Print de1.innerText
     Debug.Print de2.innerText
     Worksheets("Lancer de dés").Range("A1") = de1.innerText
     Worksheets("Lancer de dés").Range("B1") = de2.innerText
     ' on attend 10 secondes avant de fermer la fenêtre avec les dés
     objBrowser.Sleep 10
     objBrowser.quit
     Set objBrowser = Nothing
     Exit Sub
ErrHandler:
     Debug.Print "Erreur ligne " & Erl: objBrowser.quit: Set elem = Nothing: Set objBrowser = Nothing
End Sub

Ami calmant, J.P

Bonjour,

Super ça. Merci.