Comment accélérer cette petite macro

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

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

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

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

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

Bonjour Raymond,

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

Combien de temps cela met-il ?

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

Bonjour,

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

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

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.

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

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

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

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

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

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

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

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

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