Signaler

Comment accélérer cette petite macro [Résolu]

Posez votre question vieuxray - Dernière réponse le 11 janv. 2017 à 17:50 par Patrice33740
Bonjour,


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
Next

MsgBox "Terminer" 'Cells(3, 6) = "FIN" 'Fin de chargement(Durée)
Application.EnableEvents = True
End Sub
Utile
+1
plus moins
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

Cette réponse vous a-t-elle aidé ?  
Donnez votre avis
Utile
+1
plus moins
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

Cette réponse vous a-t-elle aidé ?  
Patrice33740 6130Messages postés dimanche 13 juin 2010Date d'inscription 14 septembre 2017 Dernière intervention - 10 janv. 2017 à 01:17
Bonsoir Michel, et Bonne Année.

Je ne nie pas l’efficacité de screenupdating mais dans le cas présent, c'est l'instruction objFolder.GetDetailsOf(strFileName, 27) qui est excessivement lente (chez moi prés de 6/100 sec. par instruction !).
Elle est tellement lente que le gain de temps lié au screenupdating (quelques 1/10 sec. sur l'ensemble) est négligeable par rapport au gain qu'on obtient en remplaçant l'instruction fautive.
J'ai eu du mal trouver une instruction de substitution, avec abcavi.dll (et screenupdating ) c'est déjà nettement mieux.

Cordialement
Patrice
Répondre
Donnez votre avis
Utile
+1
plus moins
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 = True

End Sub


Bien sur, ce n'est pas parfait puisque ça ne tient pas compte du type de densité...

K
Cette réponse vous a-t-elle aidé ?  
Patrice33740 6130Messages postés dimanche 13 juin 2010Date d'inscription 14 septembre 2017 Dernière intervention - 4 janv. 2017 à 21:57
Bonjour,

Il faudrait tenir compte du débit vidéo !
Sinon les erreurs sont énormes.
Répondre
Donnez votre avis
Utile
+1
plus moins
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 :
http://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 :
http://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...

Cette réponse vous a-t-elle aidé ?  
Donnez votre avis
Utile
+1
plus moins
Bonjour,
post-crossing sauvage de vieuxray alias eliott.raymond...
http://www.developpez.net/forums/d1622837/logiciels/microsoft-office/excel/macros-vba-excel/petite-macro-revoir-longue-s-executer/
Cette réponse vous a-t-elle aidé ?  
Donnez votre avis
Utile
+1
plus moins
Bonjour Raymond,

Le fichier corrigé (erreur 13) :
http://www.cjoint.com/c/GAkjrWb7fdp

Combien de temps cela met-il ?
Cette réponse vous a-t-elle aidé ?  
Donnez votre avis
Utile
+1
plus moins
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 :
http://www.cjoint.com/c/GAknrGHmwnp
Cette réponse vous a-t-elle aidé ?  
Donnez votre avis
Utile
+1
plus moins
Bonjour,

Voici le fichier avec le comptage des durées absentes :
http://www.cjoint.com/c/GAkxYEhA5wp
Cordialement
Patrice
Cette réponse vous a-t-elle aidé ?  
Donnez votre avis
Utile
+0
plus moins
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
Donnez votre avis
Utile
+0
plus moins
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.
Donnez votre avis
Utile
+0
plus moins
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
Patrice33740 6130Messages postés dimanche 13 juin 2010Date d'inscription 14 septembre 2017 Dernière intervention - 4 janv. 2017 à 17:30
Re,

Mon sata est moins rapide mais il n'est pas récent !

Non, la commande Dir et le FSO (FileSystemObject) ne permettent pas d'obtenir la durée du film !

Il est très certainement possible d'obtenir l'information en allant la lire directement dans l'en-tête binaire du fichier, mais c'est de l'art !
Et je suis assez sceptique sur le fait que ce soit plus rapide.
Répondre
Donnez votre avis
Utile
+0
plus moins
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
Patrice33740 6130Messages postés dimanche 13 juin 2010Date d'inscription 14 septembre 2017 Dernière intervention - 4 janv. 2017 à 18:12
Re,

Il n'y a aucune animosité dans mon message précédent !
Non est simplement une réponse appuyée à « Il paraît ... »

Par contre il y a peut-être une solution plus rapide mais j'en doute : Windows est lui-même très lent pour afficher la durée des films.

Cdlt
Patrice
Répondre
vieuxray- 4 janv. 2017 à 18:30
Re

Non est simplement une réponse appuyée à « Il paraît ... »

OK ca marche encore désoler:

Bon effectivement, c'est vrai que Windows 7 est long aussi mais il lit quand mème tous les renseignements sur les fichiers et il y en a pas mal.

alors que je ne souhaite qu'une seule de ces données pas facile tout ça.

sur le disque dur il ni a pas de répertoire ni sous répertoire et uniquement des fichiers (.Avi)

nom, poids, durée etc etc etc

comment extraire juste la durée ? ? ?

Merci et bonne soirée

Cdlt ray
Répondre
Donnez votre avis
Utile
+0
plus moins
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
Donnez votre avis
Utile
+0
plus moins
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
Donnez votre avis
Utile
+0
plus moins
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
Donnez votre avis
Utile
+0
plus moins
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
Donnez votre avis
Utile
+0
plus moins
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
Donnez votre avis
Utile
+0
plus moins
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
Donnez votre avis
Utile
+0
plus moins
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

Patrice33740 6130Messages postés dimanche 13 juin 2010Date d'inscription 14 septembre 2017 Dernière intervention - 11 janv. 2017 à 17:50
Ou encore :
' 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 manque 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
      manque = manque & cte & ") Film n° " & ctr & vbCrLf
    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 manque > "" Then
    manque = "Manque durée de : " & vbCrLf & manque & vbCrLf
    Range("E1").Resize(cte + 1).Value = _
       Application.Transpose(Split(manque, vbCrLf))
  End If
  MsgBox "Terminé en " & Int(temps / 60) & " min. " & _
         Int(temps Mod 60) & " sec. " & _
         Int(temps * 1000 Mod 1000) & " milièmes"
End Sub
Répondre
Donnez votre avis

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !