Problème de rotation d'une image avec VBA

Horusbk

XLDnaute Junior
Bonjour à tous :) et bonne année 2020 !

J'ai suivi cette vidéo Comment animer des Formes sur Excel (sur Youtube) car je souhaite que mes utilisateurs aient un retour visuel lorsqu'ils partagent des données à d'autres utilisateurs sur notre fichier partagé. Sur un fichier partagé, c'est en enregistrant le fichier qu'on affiche les modifications des autres utilisateurs et qu'on partage les siennes.

Grâce au tutoriel que j'ai suivi sur Youtube, je suis arrivé à une programmation me permettant de faire tourner un objet (dans mon cas il s'agit d'une image).
Pour le moment, j'ai créé un bouton "animation" pour lancer ma procédure. Toutefois, je trouve ma programmation très instable et peu fluide : parfois l'animation ne se lance pas, d'autres fois elle se lance mais de façon saccadé...

Dans l'idéal, j'aimerais une animation aussi fluide (si possible) avec 5/6 rotations comme ce gif :
kAmUPom.gif


Je vous joins un fichier de test où j'ai le code et l'image que je souhaite animer.

Merci d'avance pour votre aide, et encore une bonne année !
Baptiste.
 

Pièces jointes

  • Rotation_VBA.xlsm
    29.3 KB · Affichages: 36

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Horusbk,
Timer est une fonction dont la résolution est autour de 15ms, donc regarder si >10ms ne sert pas à grand chose.
On peut modifier la macro comme ça :
Code:
Sub Anim_Loading()
    'Déclaration des variables
    Dim Repetition As Integer
    'Affectation des variables
    Repetition = 0
    Do
    DoEvents
    'Incrementation de la répétition + (vitesse)
    Repetition = Repetition + 4
    'Animer l'image en la tournant
    Feuil1.Shapes("Image 2").Rotation = Repetition
    'Animation
    Animation (0)
    Loop Until Repetition = 1440
End Sub
En bouclant à l'infini sur 4 tours et en modifiant l'incrément de Répétition.
Mais c'est une question d'esthétique, il est possible que cela ne vous sied point.
Mais vous aurez toujours des saccades car dépend des autres taches. C'est le meilleur compromis avec ce système.

Reste l'intégration d'un GIF dans la feuille :
Mais esthétiquement je ne suis pas parvenu à retirer l'encadrement donc à mon goût je préfère la première solution.

Autre solution :
Remplacer le curseur par un petit sablier : https://www.excel-downloads.com/threads/petit-sablier-pendant-les-calculs.28536/

Autre solution, utiliser le StatusBar :
Code:
Init dans AnimLoading :
    Application.StatusBar = "I'm working ! I will be available quickly. Please, wait ....................... "
Lancement par Call ProgressStatusBar et Animation(0.15)

Sub ProgressStatusBar()
    Chaine = Application.StatusBar
    Application.StatusBar = Right(Chaine, 1) & Mid(Chaine, 1, Len(Chaine) - 1)
End Sub
L'avantage est qu'on peut se permettre un delai de 150ms pour l'action. Ce qui ne grève pas le temps d'éxecution pour le reste.
 

Horusbk

XLDnaute Junior
Bonjour sylvanu,

J'ai modifié mon code par celui que tu m'as transmis mais de mon côté, l'image ne tourne plus du tout.
Est-ce que ça fait la même chose de ton côté ?

J'avais également vu qu'on pouvait directement ajouté un Gif dans Excel avec Microsoft Web Browser mais ça ne fonctionne plus au delà de la version 2010...
 

Pièces jointes

  • Rotation_VBA_V2.xlsm
    29.6 KB · Affichages: 21

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
Désolé ... votre fichier fonctionne correctement sur mon PC (XL2007). Peut être la variable à 0, essayez en remettant 0.01
Pour les animations, beaucoup d'entre elles ont été inhibées à partir de 2010. Y compris lors de calculs multiples, XL ne raffraichit que lorsque tous les calculs sont finis. Vraiment dommage car certains effets ne sont plus possibles.
Pour faire patienter l'utilisateur, j'utilise quelquefois le StatusBar ou une cellule, au choix. ( Voir PJ ) ... si ça marche encore sous XL2010 !
Mais ça ne correspond plus à votre besoin initial.
Vous pouvez reprendre votre code initial en changeant l'incrément de Répetition, pour voir.
 

Pièces jointes

  • StatusBar.xlsm
    16.1 KB · Affichages: 18

Dranreb

XLDnaute Barbatruc
Bonjour.
Rotation plus fluide avec ce code :
VB:
Option Explicit
               #If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32.dll" _
   (ByVal hWnd As Long, ByVal Idt As Long, ByVal DuréeMS As Long, ByVal AdrSub As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32.dll" _
   (ByVal hWnd As Long, ByVal Idt As Long) As Long
               #Else
Private Declare Function SetTimer Lib "user32.dll" _
   (ByVal hWnd As Long, ByVal Idt As Long, ByVal DuréeMS As Long, ByVal AdrSub As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" _
   (ByVal hWnd As Long, ByVal Idt As Long) As Long
                  #End If
Private Shp As Shape, Ang As Long, Temps As Date
Public Sub AnimLoading()
   Set Shp = Feuil1.Shapes("Image 2")
   If Temps = 0 Then
      SetTimer Application.hWnd, Idt:=1, DuréeMS:=40, AdrSub:=AddressOf TimerProc
   Else
      Application.OnTime Temps, "ArrêtTimer", Schedule:=False
      End If
   Temps = Now + TimeSerial(0, 0, 5)
   Application.OnTime Temps, "ArrêtTimer"
   End Sub
Private Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal Idt As Long, ByVal Tic As Long)
   On Error Resume Next
   Ang = (Ang + 10) Mod 360
   Shp.Rotation = Ang
   If Err Then KillTimer Application.hWnd, Idt:=1
   End Sub
Public Sub ArrêtTimer()
   Temps = 0
   KillTimer Application.hWnd, Idt:=1
   Ang = 0
   Shp.Rotation = Ang
   End Sub
 

Horusbk

XLDnaute Junior
Re sylvanu, Dranreb,

Merci pour vos réponses.
Je vais garder sous le coup ta proposition de statusbar, sylvanu. Elle va m'être utile pour une autre fonction.

Merci pour cette optimisation Dranreb ! Ça fonctionne très bien sur 2010 et même, j'ai testé sous 2016 et 365 et rien à signaler.
Pourrais-tu m'indiquer quelles valeurs modifier afin de contrôler notamment :
- la vitesse de rotation
- le nombre de rotation

Merci d'avance.
Baptiste
 

Dranreb

XLDnaute Barbatruc
— La vitesse de rotation: Remplacez 10 par l'angle à avancer dans Ang = (Ang + 10) Mod 360
— Le nombre de rotation: Je suis parti sur une durée de l'animation plutôt. Elle se change en remplaçant le 5 par le nombre de secondes que vous voulez dans Temps = Now + TimeSerial(0, 0, 5)
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
Pour le StatusBar, un outil pour inclure un ProgressBar dans le StatusBar :
Cela permet de faire patienter l'utilisateur, mais dans l'état il faut avoir une idée de la progression de la tache.
 

Dranreb

XLDnaute Barbatruc
Oui, bien sûr, toutes variantes sont possibles. Là j'en avais fait une où c'était le cas, mais aussi, le démarrage et l'arrêt se faisaient en douceur :
VB:
Option Explicit
               #If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32.dll" _
   (ByVal hWnd As Long, ByVal Idt As Long, ByVal DuréeMS As Long, ByVal AdrSub As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32.dll" _
   (ByVal hWnd As Long, ByVal Idt As Long) As Long
               #Else
Private Declare Function SetTimer Lib "user32.dll" _
   (ByVal hWnd As Long, ByVal Idt As Long, ByVal DuréeMS As Long, ByVal AdrSub As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" _
   (ByVal hWnd As Long, ByVal Idt As Long) As Long
                  #End If
Private Temps As Date, Shp As Shape, VitAng As Long, ÇaTourne As Boolean
Public Sub AnimLoading()
   Set Shp = Feuil1.Shapes("Image 2")
   If Temps = 0 Then
      SetTimer Application.hWnd, Idt:=1, DuréeMS:=40, AdrSub:=AddressOf TimerProc
   Else
      Application.OnTime Temps, "ArrêtRotation", Schedule:=False
      End If
   Temps = Now + TimeSerial(0, 0, 5)
   ÇaTourne = True
   Application.OnTime Temps, "ArrêtRotation"
   End Sub
Private Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal Idt As Long, ByVal Tic As Long)
   On Error Resume Next
   If ÇaTourne Then
      VitAng = VitAng + 1: If VitAng > 10 Then VitAng = 10
   Else
      VitAng = VitAng - 1: If VitAng = 0 Then KillTimer Application.hWnd, Idt:=1
      End If
   Shp.Rotation = (Shp.Rotation + VitAng) Mod 360
   If Err Then KillTimer Application.hWnd, Idt:=1
   End Sub
Public Sub ArrêtRotation()
   ÇaTourne = False
   Temps = 0
   End Sub
 

job75

XLDnaute Barbatruc
Bonsoir Horusbk, sylvanu, Bernard,

Voyez le fichier joint et cette macro :
VB:
Private Sub ToggleButton1_Click()
Dim periode, s As Shape, t, a
periode = 10 'durée d'un tour complet en secondes
Set s = Feuil1.Shapes("Image 2")
ToggleButton1.Caption = IIf(ToggleButton1, "Arrêt", "Marche")
t = Timer
While ToggleButton1
    s.Rotation = 360 * (Timer - t) / periode Mod 360
    DoEvents
    Application.ScreenUpdating = True
Wend
s.Rotation = 0
End Sub
Chez moi sur Excel 2019 le code de Bernard ne va pas du tout.

A+
 

Pièces jointes

  • Rotation_VBA(1).xlsm
    34.1 KB · Affichages: 31

patricktoulon

XLDnaute Barbatruc
re
bonsoir le fil
@job75 j'aime bien le .rotation c'est nikel et sa fini toujours au point de départ simple et efficace

VB:
Sub test()
Anim_Loading Feuil1.Shapes("Image 2"), 3 '3 secondes
End Sub


Sub Anim_Loading(img, x)
        Dim  t As Double 'Déclaration des variables
    t = Timer: Affectation des variables
    Do
    DoEvents
    'Incrementation de la répétition + (vitesse)
     'Animer l'image en la tournant
    img.Rotation = 360 * (Timer - t) / x Mod 360
    'Animation
    Loop Until Timer - t >= x
End Sub
 

job75

XLDnaute Barbatruc
Bonsoir patricktoulon,

Si l'on veut conserver la position quand on arrête la rotation il suffit de la mémoriser, fichier (2) :
VB:
Private Sub ToggleButton1_Click()
Dim periode, s As Shape, t, a
periode = 10 'durée d'un tour complet en secondes
Set s = Feuil1.Shapes("Image 2")
ToggleButton1.Caption = IIf(ToggleButton1, "Arrêt", "Marche")
t = Timer
If IsNumeric([Angle]) Then a = [Angle]
While ToggleButton1
    s.Rotation = a + 360 * (Timer - t) / periode Mod 360
    DoEvents
    Application.ScreenUpdating = True
Wend
ThisWorkbook.Names.Add "Angle", s.Rotation 'mémorisation de l'angle dans un nom défini
End Sub
 

Pièces jointes

  • Rotation_VBA(2).xlsm
    33.6 KB · Affichages: 31

Statistiques des forums

Discussions
311 720
Messages
2 081 900
Membres
101 834
dernier inscrit
Jeremy06510