Problème de rotation d'une image avec VBA

Horusbk

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: 37
Trier par date Trier par votes
sylvanu

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 :
tatiak.canalblog.com

Insérer un GIF animé dans une feuille Excel! - Tatiak

Pour insérer un gif animé dans une feuille Excel :* dans la barre d'outil "Boîte à outil controles", cliquer sur la dernière icone...
tatiak.canalblog.com
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.
 
Vote positif 0 Vote négatif
Horusbk

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
Vote positif 0 Vote négatif
sylvanu

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: 19
Vote positif 0 Vote négatif
Dranreb

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
 
Vote positif 0 Vote négatif
Horusbk

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
 
Vote positif 0 Vote négatif
Dranreb

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)
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
Pour le StatusBar, un outil pour inclure un ProgressBar dans le StatusBar :
www.excel-downloads.com

Insérer un ProgressBar dans le StatusBar

On peut insérer un ProgressBar dans le StatusBar pour éviter l'utilisation d'un useform. C'est une autre méthode simple de voir la progression d'un événement. Le code est très simple à copier dans votre code , et idem pour l'appel de la fonction...
www.excel-downloads.com www.excel-downloads.com
Cela permet de faire patienter l'utilisateur, mais dans l'état il faut avoir une idée de la progression de la tache.
 
Vote positif 0 Vote négatif
Dranreb

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
 
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif
patricktoulon

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
 
Vote positif 0 Vote négatif
job75

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: 32
Vote positif 0 Vote négatif

Discussions similaires

patricktoulon
  • Résolu(e)
XL 2013 gros problème de rafraîchissement treeview avec image
2
Réponses
19
Affichages
2 K
patricktoulon
patricktoulon
lakriti said
  • Question
XL 2016 Rotation continue d'une image autour d'axe y et à l'ouverture de fichier
Réponses
9
Affichages
2 K
lakriti said
lakriti said
U
  • Résolu(e)
XL 2019 Duppliquer formule VBA (afficher la date automatique lors d'une saisie) + Problème VBA cellules protégées
Réponses
11
Affichages
1 K
ugo13
U
M
[REF] Wiki 1 de MichelXld (Généralités Excel)
Réponses
6
Affichages
59 K
Le_Phénomène
Le_Phénomène

Membres actuellement en ligne

14 membres et 116 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 133
Messages
2 116 602
Membres
112 801
dernier inscrit
Yaz113