Besoins d'aide pour combiner 2 macros

[Chris57]

bonjour à tous,

j'ai une macro qui me permet de lister les noms de fichiers d'un dossier :

Sub OUVERTUREDossier()
    ' Demande quel type de fichier à choisir
            Extension = InputBox("Quel type de fichier voulez-vous traiter ?" & Chr(13) & "            (ne pas mettre le point)" & Chr(13) & Chr(13) & "Si vous voulez traiter tous les fichiers," & Chr(13) & "mettre simplement une ""*""", "DEFINIR L'EXTENSION", "*")
            If Extension = Cancel Then Exit Sub
    
    ' Ouverture popup dossiers
            ChDir ThisWorkbook.Path   ' répertoire de l'appli
            Dossier = ChoixDossier()
            If Dossier = "" Then Exit Sub
        
         
' Récupérations des noms des fichiers selon extention choisie
    Application.ScreenUpdating = False
    Ligne = 10
    NOMfichier = Dir("*." & Extension)
    Do While NOMfichier <> ""
                Cells(Ligne, 2) = NOMfichier                
    Ligne = Ligne + 1
    NOMfichier = Dir                  ' suivant
    Loop    
End Sub

et une autre permettant de d'inscrire les propriétés de ces fichiers :

 ' Récupération des propriétés des fichiers
            Dim objShell As Shell32.Shell
            Dim strFileName As Shell32.FolderItem
            Dim objFolder As Shell32.Folder
            Dim Resultat As String, Reponse As String
            Dim i As Byte
            
            Set objShell = CreateObject("Shell.Application")
            'Répertoire cible
            Set objFolder = objShell.Namespace(Dossier)
             a = 0
            'boucle sur tous les elements du repertoire
            For Each strFileName In objFolder.Items
                If strFileName.IsFolder = False Then        'Pour que les dosssiers ne soient pas pris en comptes
                    If objFolder.GetDetailsOf(NOMfichier, i) <> "" Then
                        a = a + 1
                        [E10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 1)   '  Taille
                        [F10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 3)   '  Modifié le
                        [G10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 4)   '  Date de création
                        [H10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 13)   '  Artistes ayant participé
                        [I10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 14)   '  Album
                        [J10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 15)   '  Année
                        [K10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 16)   '  Genre
                        [L10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 20)   '  Auteurs
                        [M10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 21)   '  Titre
                        [N10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 24)   '  Commentaires
                        [O10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 26)   '  N°
                        [P10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 27)   '  Longueur
                        [Q10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 28)   '  Vitesse de transmission
                        [R10].Offset(a, 0) = objFolder.GetDetailsOf(strFileName, 31)   '  Dimensions
                    End If
                End If
            Next

pourriez-vous m'aider à combiner les 2 pour que lorsque la première macro inscrit le nom d'un fichier, la seconde inscrive les propriétés de ce même fichier ?

 

[Staple1600]

Re : Besoins d'aide pour combiner 2 macros

Bonsoir

Pourquoi récréer un second fil pour un même sujet ?
Le premier ici
https://www.excel-downloads.com/threads/retagger-avec-excel.168348/

Une petite relecture de la charte serait à envisager, non ?

 

[Chris57]

Re : Besoins d'aide pour combiner 2 macros

C'est toi qui devrait relire
le premier sujet parle de renommage et de retaggage d'MP3 à partir d'excel et est encore ouvert car j'ai pas encore terminé. Ce sujet ci traite de l'affichage de propriétés de fichiers.

 

[flyonets44]

Re : Besoins d'aide pour combiner 2 macros

Bonjour
tout simplement ceci
Do While NOMfichier <> ""
Cells(Ligne, 2) = NOMfichier
call macro propriétés_fichiers
Ligne = Ligne + 1
NOMfichier = Dir ' suivant
Loop
Cordialement
Flyonets

 

[Staple1600]

Re : Besoins d'aide pour combiner 2 macros

Bonjour

Mea culpa

Au lieu de combiner tu peux en utiliser qu'une
strFileName te donnant le nom du fichier en modifiant comme ci-dessous.

For Each strFileName In objFolder.Items
                If strFileName.IsFolder = False Then        'Pour que les dosssiers ne soient pas pris en comptes
Cells(a,2)=strFileName

 

[Chris57]

Re : Besoins d'aide pour combiner 2 macros

Bonjour
Mea culpa

pas de pb !! C'est pas faute aussi parce que je bosse sur plusieurs trucs en même temps...

flyonets44, ton idée est pas mal mais le problème est que la seconde macro boucle sur tous les fichiers du dossier.
Au lancement, la première macro va inscrire le nom du premier fichier du dossier, mais si j’appelle la seconde, elle va inscrire les propriétés de tous les fichiers du dossier ! Une fois fait, la première passera seulement au 2ème fichier et va rappeler la seconde macro qui va encore inscrire les propriétés de tous les fichiers du dossier !

Staple1600, je vais tenter quelque chose...

 

[Chris57]

Re : Besoins d'aide pour combiner 2 macros

Voilà,
j'ai réussit à faire ça :

Function ChoixDossier()
' Fonction pour ouverture popup Dossiers
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "SELECTION DES FICHIERS A TRAITER"
.AllowMultiSelect = True
.InitialView = msoFileDialogViewProperties
.InitialFileName = [D3] & "\"
.Show
If .SelectedItems.Count > 0 Then
ChoixDossier = .SelectedItems(1)
Else
ChoixDossier = ""
End If
End With

If ChoixDossier <> "" Then [D3] = ChoixDossier
End Function

Sub OUVERTUREDossier()
SELECTIONtoutACTIF = 0
SELECTIONpartielleACTIVE = 0

' Ouverture popup dossiers
ChDir ThisWorkbook.Path ' répertoire de l'appli
Dossier = ChoixDossier()
If Dossier = "" Then Exit Sub

Application.ScreenUpdating = False
Dim objShell As Shell32.Shell
Dim strFileName As Shell32.FolderItem
Dim objFolder As Shell32.Folder
Dim Resultat As String, Reponse As String
Dim i As Byte
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(Dossier) 'Répertoire cible
Ligne = 10


' Récupération des noms et propriétés des fichiers
For Each strFileName In objFolder.Items
If strFileName.IsFolder = False Then 'Pour que les dosssiers ne soient pas pris en comptes
Cells(Ligne, 2) = strFileName
Cells(Ligne, 5) = objFolder.GetDetailsOf(strFileName, 27) ' Durée
Cells(Ligne, 6) = objFolder.GetDetailsOf(strFileName, 1) ' Taille
Cells(Ligne, 7) = objFolder.GetDetailsOf(strFileName, 28) ' Vitesse de transmission
Cells(Ligne, 8) = objFolder.GetDetailsOf(strFileName, 20) ' Auteurs
Cells(Ligne, 9) = objFolder.GetDetailsOf(strFileName, 21) ' Titre
Cells(Ligne, 10) = objFolder.GetDetailsOf(strFileName, 14) ' Album
Cells(Ligne, 11) = objFolder.GetDetailsOf(strFileName, 13) ' Artistes ayant participé
Cells(Ligne, 12) = objFolder.GetDetailsOf(strFileName, 15) ' Année
Cells(Ligne, 13) = objFolder.GetDetailsOf(strFileName, 16) ' Genre
Cells(Ligne, 14) = objFolder.GetDetailsOf(strFileName, 24) ' Commentaires
Cells(Ligne, 15) = objFolder.GetDetailsOf(strFileName, 4) ' Date de création
Cells(Ligne, 16) = objFolder.GetDetailsOf(strFileName, 3) ' Modifié le
Cells(Ligne, 17) = objFolder.GetDetailsOf(strFileName, 26) ' N°
Ligne = Ligne + 1
End If
Next
End Sub

ça fonctionne très bien mais ça rame si j'ouvre un dossier contenant beaucoup de fichiers.
Je me demande s'il ne serai pas possible d'optimiser, mais ça dépasse mes connaissances.
Si quelqu'un a une idée !!

 

[Chris57]

Re : Besoins d'aide pour combiner 2 macros

tentative de up...

 

[Staple1600]

Re : Besoins d'aide pour combiner 2 macros

Bonjour le fil

Chris57
Qu'est-ce que tu entends par ça rame ?
(Combien de minutes pour exécuter la macro
et combien de fichiers en gros ?)

 

[Chris57]

Re : Besoins d'aide pour combiner 2 macros

Là j'ai testé avec un fichier contenant 407 fichiers (mon classeur est limité à 500 fichiers à la fois, valeur que j'ai choisi un peu au hasard).
Pour 407 mp3 il lui faut plus de 30 sec.
Évidement si le dossier est plus modeste, la durée d’exécution est acceptable. Mais j'ai fréquemment des dossier contenant plusieurs centaines de mp3 ou de photos !!
Bien sûr c'est pas la fin du monde, mais si on pouvait accélérer...

Ci-joint mon classeur (en cours de fabrication) avec les 407 fichiers :
Cijoint.fr - Service gratuit de dépôt de fichiers

j'ai séparé la macro d'ouverture et de lecture des commentaires a cause de la durée d’exécution.