Comment accélérer cette petite macro Résolu/Fermé

Question

Bonjour, 
Configuration: Windows 7 32 bits/I-E . 11
Bonjour a tous, forum bonjour,
 Excel 2007 et Windows 7 32 bits
 Le code ci-dessous a pour rôle de m'afficher dans la colonne (C) (feuil1) la durée de mes fichiers (.Avi) elle fonctionne très bien SAUF qu'elle est un peu trop longue a s’exécuter  ce code mets 2Mn 20s pour 2010 fichiers.
 J'espère qu'il ai possible d'améliorer ce code où bien une autre façon de coder car j'ai du sans doute mal faire.
ça me parait bizarre que ce soit aussi long a s'afficher, 2010 fichiers c'est pas beaucoup pour un ordi bien équiper correctement.
 Merci a vous et si votre temps le permets de bien vouloir regarder le code. afin d'accélérer son fonctionnement.
 Merci pour votre aide et bonne journée a tous 
 Cdlt Ray
La ligne de code ci dessous serai la source du ralentissement m'a t'on dit.
 For Each strFileName In objFolder.Items                       
### AFFICHE LA (DUREE) DES FICHIERS Public Sub Listing_Affiche_la_Durée() Application.EnableEvents = False Range("C1:C4000").ClearContents                                   'Efface colonne C Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.Namespace("H:\")                    'Adapter le chemin du Disque dur R = 1 For Each strFileName In objFolder.Items                       'Boucle sur les fichiers "avi" du répertoire If Right(objFolder.GetDetailsOf(strFileName, 0), 4) = ".avi" Then _ Cells(R, 3) = objFolder.GetDetailsOf(strFileName, 27) 'Durée R = R + 1 NextMsgBox "Terminer"                                          'Cells(3, 6) = "FIN" 'Fin de chargement(Durée) Application.EnableEvents = True End Sub

michel_m · Answer

Bonjour,
déjà en début de macro après les déclarations que tu as négligées, écris
Application.screenupdating=False 
pour la rapidité et le confort visuel 
 Michel

vieuxray · Answer

Salut Michel,
Merci pour ta réponse, c'est sympa.
Le code n'ai pas de moi, une trouvaille sur le net.
j'ai tester ce fameux code que j'ai poster sur 200 fichiers ca a été rapide mais avec 2010 c'est plus la même histoire, d'où mon post.
--------------
déjà en début de macro après les déclarations que tu as négligées, écris 
Question: J'ai négliger quoi exactement svp que je corrige ????  
Application.screenupdating=False
 Pour la rapidité et le confort visuel. 
Fait plusieurs essais, résultat temps d'exécution identique.
----------------
Il y a d'autres méthodes rapides si on a un nombre important de fichiers (env. 1500) .avi comme on n'en sait pas le nombre.... 
Le nombre de fichiers aujourd'hui est de 2010 comme écrit dans mon post
Je veux bien svp un code plus rapide comme tu me le propose.
car 2Mn 20s pour afficher 2010 durées de film, c'est beaucoup trop long pour un Pc comme je le disais.
Merci a toi et pour ton aide, bonne après midi
sinon je ne sais pas faire autrement pour gagner en rapidité.
Cdlt Ray

Patrice33740 · Answer

Bonjour Ray
Effectivement, que ce soit avec ScreenUpdating = False ou Calculation = xlCalculationManual on ne gagne quasiment rien en vitesse d'exécution.
La lenteur est essentiellement due au temps d'accès à ton disque dur externe. J'obtiens des temps similaires avec un HDD USB2 sur un port USB2 et 20% plus rapide sur un port USB3, que ce soit un HDD USB2 ou USB3.

vieuxray · Answer

Salut Patrice33740,
Merci pour ta réponse, c'est sympa.
Ha, on n'ai mal alors.
Je n'ai pas de disque dur externe mais un interne en disque Sata récent et l'accès est rapide, 3 Téras connecter dans ma tour.
Pour le code Il paraitrai qu'il serait possible d'aller vite plus avec la commande DIR pour afficher juste la durée des vidéos.
Mais ca dépasse mes capacités VBA.
Je n'ai rien trouver pour l'instant, c'est dommage car le reste du programme tourne plutôt bien.
Bonne soirée et merci a toi.
Cdlt Ray

michel_m · Answer

Bonjour Patrice
Tu me déçois car tu proposes souvent d'excellentes solutions :-/
tu écris
Effectivement, que ce soit avec ScreenUpdating = False ou Calculation = xlCalculationManual on ne gagne quasiment rien en vitesse d'exécution
AH BON ?

ci joint test rapidité avec ou sans screenupdating et avec variable tableau...
https://mon-partage.fr/f/WF5DaXfj/
Pour ray
Je veux bien svp un code plus rapide comme tu me le propose

Inutile de me fatiguer puisque tu dis qu'un truc de base que l'on apprend dès les 1° heures de lecture d'un topo sur VBA (screenupdating)ne sert à rien
 Michel

vieuxray · Answer

Salut 
non non non j'ai dit ce que j'ai lu c'est tout aucune prétention a quoi que se soit et encore moins sur votre savoir.
quand je saurai le dixième de ce que vous savez 
peut être je pourrai dire mon point de vue mais c'est pas pour demain
mais la je suis une toute petite étoile dans l'univers du vba
désoler et toutes mes excuses si mal dit
bon si pas possible tant pis, ca marche quand même mais c'est long quand on attends 
Cdlt Ray

Kalissi · Answer

Bonjour,
Une idée à prendre ou à laisser.
Si la précision de la durée n'est pas requise, il est possible d'effectuer une règle de 3 sur le poids du fichier.
Une méthode du style :
Public Sub Lecture()    Application.ScreenUpdating = False    Application.EnableEvents = False    Dim Chemin As String    Dim Facteur As Double    Dim Compteur As Integer    Dim objFSO As Variant, objDossier As Variant, objFichier As Variant    Chemin = "C:\Document"    Set objFSO = CreateObject("Scripting.FileSystemObject")    Set objDossier = objFSO.GetFolder(Chemin)    Compteur = 0    For Each objFichier In objDossier.Files        'Postulat :        '60 minute = 300 MG        ' x Minute = 700 MG        'x = ( 700 * 60 ) / 300        ActiveCell.Offset(Compteur, 0).Value = (objFichier.Size * 60) / 300        Compteur = (Compteur + 1)    Next    Application.EnableEvents = True    Application.ScreenUpdating = TrueEnd Sub
Bien sur, ce n'est pas parfait puisque ça ne tient pas compte du type de densité...
K

vieuxray · Answer

Bonjour a tous, 
merci pour vos réponses,
bon je vois que c'est pas facile cette histoire d'affichage durée.
Donc je reste avec ma sub durée LOL
je ne sais pas combien de temps ca mettra quand j'aurai plus de fichiers ???
je prévoirai un café et un casse croute. un peu d'humour 2017
bonne journée a vous
Cdlt Raymond

Patrice33740 · Answer

Bonjour Raymond
Finalement, il y a moyen d’accélérer le code en utilisant la dll abcavi.dll.
Le gain de vitesse est substantiel, mais il faut ajouter et installer cette dll :
https://www.cjoint.com/c/GAjxHbMB3Up  
Pour l'installer sur windows 32 bits :
1) Copier la dll (abcavi.dll) dans c:\Windows\System32\
2) Enregistrer la dll dans le registre :
- ouvrir une Invite de Commande en temps qu'administrateur
- taper : Regsvr32.exe c:\Windows\System32\abcavi.dll
- Un message indique que la commande a réussi.
Pour l'installer sur windows 64 bits :
1) Copier la dll (abcavi.dll) dans c:\windows\SysWow64\
2) Enregistrer la dll dans le registre :
- ouvrir une Invite de Commande en temps qu'administrateur
- taper : Regsvr32.exe c:\Windows\SysWow64\abcavi.dll
- Un message indique que la commande a réussi.
Pour plus d'informations, consulter le site des développeurs suivants :
http://abcavi.kibi.ru/dll_help/index.html
http://abcavi.kibi.ru/developer.htm 
Voici un fichier Excel exploitant cette dll :
https://www.cjoint.com/c/GAjxNEuSrGp
Si tu saisit le code VBA dans un autre fichier, pense à établir une référence à "abcAVI Info Library" :
Editeur VBA/barre des menus/outils/références...

vieuxray · Answer

Bonjour a tous, forum bonjour
Tout d'abord bonne année et bonne santé a tous.
Salut Patrice 33740,
Merci beaucoup pour le coup de main j'imagine que tu a bien du bien chercher pour trouver la Dll et de refaire le code.
Installation de la Dll dans system32 c'est bon.
J'ai essayer le code mais j'ai une erreur (d'incompatibilité de type)
j'ai eu ce message arriver au fichier 487, je crois avoir trouver, ce serai du au fait que ce fichier de comporte pas de (Durée)
j'ai vérifier directement sur mon DD et effectivement il ni a pas de durée a ce fichier et d'ailleurs, j'en ai d'autres qui n'on pas la durée non plus.
Un test svp dans le cas ou un fichier n'a pas de durée serai le bienvenue.
Déjà sur 487 fichiers ca va vite, j'ai hâte de voir le final, encore merci a toi et
passe une agréable journée. 
A plus tard 
Cdlt Raymond

michel_m · Answer

Bonjour,
post-crossing sauvage de vieuxray alias eliott.raymond...
https://www.developpez.net/forums/d1622837/logiciels/microsoft-office/excel/macros-vba-excel/petite-macro-revoir-longue-s-executer/ 
 Michel

Patrice33740 · Answer

Bonjour Raymond,
Le fichier corrigé (erreur 13) :
https://www.cjoint.com/c/GAkjrWb7fdp 
Combien de temps cela met-il ?

vieuxray · Answer

Re salut Patrice,
Merci pour la modification du code.
Alors c'est bon ca fonctionne bien plus d'erreur, je t'ai mis
un commentaire sur l'image ci-jointe
Pour le temps a mon chrono 1Mn et 25secondes
Dans la msgbox je comprends pas l'affichage
http://www.cjoint.com/c/GAkkkkvpqfz
Merci a toi
Cdlt Ray

Patrice33740 · Answer

Re,
L'affichage de la msgbox 84,16016 secondes c'est 84 secondes et 16016 cent millièmes de seconde ou si tu préfères 1 minute 24 secondes et 16 dixième !!!
On est légèrement plus rapide en utilisant un tableau pour mémoriser les durées. Voila le dernier fichier :
https://www.cjoint.com/c/GAknrGHmwnp

vieuxray · Answer

Re Patrice,
Merci pour le fichier modifier, ca fonctionne bien résultat 1minute de gagner
c'est pas mal du tout, bravo bien jouer.
Fait 8 essais avec la dernière version résultat entre 1.24 et 1.28 pour 2009 fichiers exactement et temps de 2.20 au début de mon post.
c'est très bien comme ça, pas sur de pouvoir faire mieux LOL
Une dernière modification si tu veux bien et quand tu a du temps rien ne me presse.
Pourrait tu svp faire si c'est possible en sorte de compter les fichiers qui n'ont pas de durée et plus le N° correspondant au film et afficher le résultat dans un label.
Exemple d'affichage dans le label "Film N° 487" & "Manque durée (1)" ou 2, ou plus bien sur.
Merci a toi et mes félicitations.
Je vais adapter a mon fichiers sans tarder
Cdlt Raymond

Patrice33740 · Answer

Bonjour,
Voici le fichier avec le comptage des durées absentes :
https://www.cjoint.com/c/GAkxYEhA5wp
Cordialement
Patrice

vieuxray · Answer

Salut Patrice,
Merci pour ta réponse, c'est sympa.
Cela fonctionne très bien, le nombre et numéro corresponde bien aux manques de durée.
Refait des essais ce matin même avec le dernier fichier que tu a fait et le temps est de 1 Mn 24 Sc 881 Milli pour 2009 fichiers.
c'est bon pour moi, je fini d'adapter a mon programme.
Je te remercie pour ton savoir et ta ténacité.
Je te souhaite de passer une agréable journée et encore un grand merci a toi.
Bien Cordialement Raymond

vieuxray · Answer

Re Patrice, 
Je croyais pouvoir arriver a copier les infos que tu affiches a la fin du code  dans le (MsgBox) 
Dans la colonne (E:E1) de cette manière ci-dessous, mais j'ai une "erreur 400"
E1 = Manque de durée :
E2 = 1) Film n°487
E2 = 2) Film n°
E3 = etc etc
et a la fin afficher du MsgBox (Terminé en etc etc)
But pas besoin du "MsgBox" dans mon programme.
j'ai chercher, modifier, essayer, ce qui m'étonne c'est toujours même message qui revient.
Si tu peux svp me faire ca, a moins que cela viendrai du code, mais j'en voie pas vraiment la raison, je t'en remercie, je retourne essayer.
Cdlt Ray

Patrice33740 · Answer

Bonjour Raymond.
Voici le code :
' Ajouter une référence à "abcAVI Info Library"
' (barre des menus/Outils/Références...)
Option Explicit
Public Sub Listing_Affiche_la_Durée()
' Liste la durée des films
'
Const chemin$ = "F:\Films\Action"          'Adapter le répertoire
Const nbmax% = 5000                        'Adapter nbre max de films
Dim tag As New abcAVI.ExtendedAVITags
Dim AviInfos As Variant
Dim lgr(1 To nbmax) As Variant
Dim fichier As String
Dim début As Single
Dim temps As Single
Dim ctr As Integer
Dim cte As Integer

début = Timer
  Application.EnableEvents = False
  Range("C1:C" & nbmax).ClearContents
  Range("E1:C" & nbmax).ClearContents
  Application.ScreenUpdating = False
  fichier = Dir(chemin & "\*.avi")
  ctr = 1
  Do While Len(fichier) > 0
    Cells(ctr, 3).Value = fichier
    tag.ReadAVITags chemin & "\" & fichier, PM_Lite_Mode + _
                    PM_Tech_Info, 0, AviInfos
    On Error Resume Next
    lgr(ctr) = tag.GetInfo(AviInfos, IDI_Video_Stream, IDV_Duration)
    lgr(ctr) = lgr(ctr) / (24# * 3600# * 1000#)
    If Err.Number > 0 Then
      lgr(ctr) = ""
      cte = cte + 1
      Range("E1").Offset(cte).Value = cte & ") Film n° " & ctr
    End If
    On Error GoTo 0
    ctr = ctr + 1
    fichier = Dir
  Loop
  Range("C1").Resize(ctr).Value = Application.Transpose(lgr)
  Range("C1").Resize(ctr).NumberFormat = "hh:mm:ss"
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  
  temps = Timer - début
  If cte > 0 Then Range("E1").Value = "Manque durée de : "
  MsgBox "Terminé en " & Int(temps / 60) & " min. " & _
         Int(temps Mod 60) & " sec. " & _
         Int(temps * 1000 Mod 1000) & " milièmes"
End Sub

Comment accélérer cette petite macro

19 réponses

Discussions similaires