Résolu 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 :


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.
 

Fichiers joints

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...
 

Fichiers joints

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.
 

Fichiers joints

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.
 

Horusbk

XLDnaute Junior
Merci de vos réponses :)
Dranred, une fois l'animation arrivant à son terme, est-ce possible que l'image ne se remette pas dans sa position d'origine ?
 

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+
 

Fichiers joints

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
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Bonsoir job75, et bonne année.
Qu'est-ce qui ne va pas avec mon code sur Excel 2019 ?
Problème d'office à 32 bits ou est-ce Excel qui n'aime pas être interrompu n'importe quand par le timer, même juste pour le repositionnement d'un Shape ?
 

job75

XLDnaute Barbatruc
Bonjour Bernard,

Tu remarqueras que ma macro utilise Application.ScreenUpdating = True

Chez moi sur Excel 2019 (64 bits) cette mise à jour est indispensable, ton code et celui de patricktoulon ne fonctionnent donc pas.

Très bonne année 2020.

A+
 

Dranreb

XLDnaute Barbatruc
Bonjour job75.
Oui j'avais déjà vu ça quelque part. Mais tu disais que ça ne va pas du tout, alors je pensais que c'était plus grave. Si je rajoute Application.ScreenUpdating = True derrière Shp.Rotation = (Shp.Rotation + VitAng) Mod 360, ça ne plante pas, chez moi, mais l'animation devient très fortement saccadée.
 
Dernière édition:

Modeste geedee

XLDnaute Barbatruc
Bonsour®
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.
peux-tu préciser ....
info knowlegebase ???
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas