(re)Sortir l'auteur de fichiers Excel (VBA)

bonjour,

Voici un exemple avec Shell

Sub ListeProprietesFichiers_getDetailsOf()
'source:
'http://www.microsoft.com/resources/documentation/windows/2000/server/
'scriptguide/en-us/sas_fil_lunl.mspx
'
'Nécessite d'activer la référence Microsoft Shell Controls and Automation
'
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("C:UsersisabelleDocuments")

'boucle sur tous les elements du repertoire
For Each strFileName In objFolder.Items

'Pour que les dossiers ne soient pas pris en comptes
If strFileName.isFolder = False Then
Resultat = ""
For i = 0 To 34
If objFolder.getDetailsOf(strFileName, i) <> "" Then _
Resultat = Resultat &
objFolder.getDetailsOf(objFolder.Items, i) _
& ": " & objFolder.getDetailsOf(strFileName, i) & vbLf
Next
Reponse = MsgBox(Resultat & vbLf & vbLf & "Voulez vous continuer?",
vbYesNo)
If Reponse = vbNo Then Exit Sub
End If
Next
End Sub

isabelle

Le 2015-06-16 09:43, Emile63 a écrit :

Bonjour à tous,

Je cherche lister sur une feuille XL les fichiers (xl) que j'ai sur certains répertoires de mon >

disque dur, avec l'extrait de VBA ci-après, et cela fonctionne bien. Aujourd'hui
je souhaiterais

améliorer ce code pour y faire figurer le nom de l'auteur (s'il y a) en plus des Noms de fichiers,
taille et date que j'ai actuellement.Malheureusement en ajoutant Autor ca ne fonctionne pas... :-(
--> Voir ici..
-Quelqu'un aurait la solution à mon problème? :-)

Merci d'avance pour votre aide!
Emile
------------------------------------------------------

Sub Lit_dossier(ByRef dossier, ByVal niveau, MaListe)
Dim d As Object, f As Object, nom_fich As String

ActiveCell.Value = decal(niveau - 1) & dossier.Name & "[" & dossier.Path & "]"
ActiveCell.Interior.ColorIndex = 36
ActiveCell.Offset(1, 0).Select
For Each d In dossier.SubFolders
Lit_dossier d, niveau + 1, MaListe
Next
[A4] = "Fichiers"
[B4] = "Taille"
--> [C4] = "Auteur"
[D4] = "Date"
ActiveCell.Offset(1, 0).Select
For Each f In dossier.Files
nom_fich = f.Name

If nom_fich Like MaListe Then
ActiveCell = decal(niveau) & nom_fich
ActiveCell.Offset(0, 1) = f.Size

--> ActiveCell.Offset(0, 2) = f.Author <----

ActiveCell.Offset(0, 3).HorizontalAlignment = xlRight
ActiveCell.Offset(0, 3).NumberFormat = "dd/mm/yyyy hh:mm"
ActiveCell.Offset(0, 3) = f.DateLastModified
ActiveCell.Interior.ColorIndex = 2
ActiveCell.Offset(1, 0).Select
End If
Next
End Sub

plus spécifiquement selon ta demande
Nom, Taille, Date, Auteurs
à noter que
.Items, 0 = Nom
.Items, 1 = Taille
.Items, 4 = Date de création
.Items, 20 = Auteurs

autre possibilitées:
.Items, 3 = Modifié le
.Items, 5 = Date d’accès

Sub ListeProprietesFichiers_getDetailsOf()
'Nécessite d'activer la référence Microsoft Shell Controls and Automation

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
Dim x As Integer

Set objShell = CreateObject("Shell.Application")
'Répertoire cible
Set objFolder = objShell.Namespace("C:UsersisabelleDocuments__isabelle")

'boucle sur tous les elements du repertoire
For Each strFileName In objFolder.Items

'la ligne 1 pour les titres de colonne
If x <= 0 Then
Cells(1, 1) = objFolder.GetDetailsOf(objFolder.Items, 0)
Cells(1, 2) = objFolder.GetDetailsOf(objFolder.Items, 1)
Cells(1, 3) = objFolder.GetDetailsOf(objFolder.Items, 4)
Cells(1, 4) = objFolder.GetDetailsOf(objFolder.Items, 20)
x = 1
End If

'Pour que les dossiers ne soient pas pris en comptes
If strFileName.isFolder = False Then
'Pour vérifier seulement les fichiers Excel
If Not IsError(Application.Find("Excel",
objFolder.GetDetailsOf(strFileName, 2))) Then
x = x + 1
Cells(x, 1) = objFolder.GetDetailsOf(strFileName, 0)
Cells(x, 2) = objFolder.GetDetailsOf(strFileName, 1)
Cells(x, 3) = objFolder.GetDetailsOf(strFileName, 4)
Cells(x, 4) = objFolder.GetDetailsOf(strFileName, 20)
End If
End If
Next
End Sub

isabelle

Bonjour Isabelle,

Je te remercie pour ton aide :-)
Il manque la fin de la ta proc. (copier / coller à du s'égarer un peu), mais c'est bien ce que je cherchais. :-)

Sans vouloir abuser, est-ce que tu peux m'aider (encore), je souhaiterais f aire une boucle sur cet objet et lister tous ses items avec leurs n° de p osition.

Encore merci pour ta sollicitude.
Cordialement,
Emile

Bonjour,

La procédure adaptée à ce nouveau besoin

La feuille affichant le résultat est présumée vide.

Tu as la liste de toutes les propriétés, mais chacune de ces dernières ne
s'applique pas nécessairement à un type de fichier Excel...

'---------------------------------------------------------------------------------
Sub ListeProprietesFichiers_getDetailsOf()
'Nécessite d'activer la référence Microsoft Shell Controls and Automation
Dim objShell As Shell32.Shell
Dim strFileName As Shell32.FolderItem
Dim objFolder As Shell32.Folder
Dim A As Long, x As Long, Répertoire As String

'définir le répertoire où sont les fichiers
Répertoire = "c:UsersTon profilDocuments"

'Tester si ce répertoire existe
If Dir(Répertoire, vbDirectory) = "" Then
MsgBox "Ce répertoire """ & Répertoire & """ n'existe pas."
Exit Sub
End If

Set objShell = CreateObject("Shell.Application")
'Répertoire cible
Set objFolder = objShell.Namespace(Répertoire)
Application.ScreenUpdating = False
'boucle sur tous les elements du repertoire
For Each strFileName In objFolder.Items
'la ligne 1 pour les titres de colonne
If Cells(1, 1) = "" Then
For x = 1 To 34
Cells(1, x) = objFolder.GetDetailsOf(objFolder.Items, x - 1)
Next
End If

'Pour que les dossiers ne soient pas pris en comptes
If strFileName.isFolder = False Then
'Pour vérifier seulement les fichiers Excel
If Not IsError(Application.Find("Excel", objFolder.GetDetailsOf(strFileName, 2))) Then
'la ligne 1 pour les titres de colonne
For x = 1 To 34
Cells(2 + A, x) = objFolder.GetDetailsOf(strFileName, x - 1)
Next
A = A + 1
End If
End If
Next
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------------------------





"Emile63" a écrit dans le message de groupe de discussion :
795d9e17-42ed-4678-9bbb-a5eceba67219@googlegroups.com...

Bonjour Isabelle,

Je te remercie pour ton aide :-)
Il manque la fin de la ta proc. (copier / coller à du s'égarer un peu), mais c'est bien ce que je
cherchais. :-)

Sans vouloir abuser, est-ce que tu peux m'aider (encore), je souhaiterais faire une boucle sur cet
objet et lister tous ses items avec leurs n° de position.

Encore merci pour ta sollicitude.
Cordialement,
Emile

Bonjour Denis

Est-ce que ce filet de macro pourrait me lister sur une feuille Excel, tous
les documents enregistrés sur le disque C et ayant une extension .GDB (Map
Source)?
Grand merci et bonne fin de journée.
Jacques
--------------------------------------------
sub zaza()
Set fs = Application.FileSearch
With fs
.LookIn = "C:Documents and SettingsflorenceApplication
DataMicrosoftExcel"
.Filename = "*"
.Execute
For i = 1 To .FoundFiles.Count
MsgBox .FoundFiles(i)
Next i
If .FoundFiles.Count = 0 Then
MsgBox "Aucun fichier n'a été trouvé."
End If
End With
end sub
Si dans cette procédure j'écris : .FileName = "F*.*" Et bien j'obtiens tous
les fichiers débutant par la lettre F du répertoire choisi. Si j'écris :
.FileName = "F*" J'obtiens seulement le nombre de fichiers dont les
extensions font partie de la constante "msoFileTypeOfficeFiles;Je cherche
une macro qui me liste tous les fichiers d'un répertoire quelconque
Auteur(s) :
Denis Michon, Laurent Mortézai, Isabelle
Soumis par Misange le sam, 09/15/2012 - 08:00
------------------------------------------------------------------------
Jacquouille

" Le vin est au repas ce que le parfum est à la femme."
"MichD" a écrit dans le message de groupe de discussion :
mm97ig$e2r$1@speranza.aioe.org...

Bonjour,

La procédure adaptée à ce nouveau besoin

La feuille affichant le résultat est présumée vide.

Tu as la liste de toutes les propriétés, mais chacune de ces dernières ne
s'applique pas nécessairement à un type de fichier Excel...

'---------------------------------------------------------------------------------
Sub ListeProprietesFichiers_getDetailsOf()
'Nécessite d'activer la référence Microsoft Shell Controls and Automation
Dim objShell As Shell32.Shell
Dim strFileName As Shell32.FolderItem
Dim objFolder As Shell32.Folder
Dim A As Long, x As Long, Répertoire As String

'définir le répertoire où sont les fichiers
Répertoire = "c:UsersTon profilDocuments"

'Tester si ce répertoire existe
If Dir(Répertoire, vbDirectory) = "" Then
MsgBox "Ce répertoire """ & Répertoire & """ n'existe pas."
Exit Sub
End If

Set objShell = CreateObject("Shell.Application")
'Répertoire cible
Set objFolder = objShell.Namespace(Répertoire)
Application.ScreenUpdating = False
'boucle sur tous les elements du repertoire
For Each strFileName In objFolder.Items
'la ligne 1 pour les titres de colonne
If Cells(1, 1) = "" Then
For x = 1 To 34
Cells(1, x) = objFolder.GetDetailsOf(objFolder.Items, x - 1)
Next
End If

'Pour que les dossiers ne soient pas pris en comptes
If strFileName.isFolder = False Then
'Pour vérifier seulement les fichiers Excel
If Not IsError(Application.Find("Excel",
objFolder.GetDetailsOf(strFileName, 2))) Then
'la ligne 1 pour les titres de colonne
For x = 1 To 34
Cells(2 + A, x) = objFolder.GetDetailsOf(strFileName, x - 1)
Next
A = A + 1
End If
End If
Next
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------------------------





"Emile63" a écrit dans le message de groupe de discussion :
795d9e17-42ed-4678-9bbb-a5eceba67219@googlegroups.com...

Bonjour Isabelle,

Je te remercie pour ton aide :-)
Il manque la fin de la ta proc. (copier / coller à du s'égarer un peu), mais
c'est bien ce que je
cherchais. :-)

Sans vouloir abuser, est-ce que tu peux m'aider (encore), je souhaiterais
faire une boucle sur cet
objet et lister tous ses items avec leurs n° de position.

Encore merci pour ta sollicitude.
Cordialement,
Emile


---
L'absence de virus dans ce courrier électronique a été vérifiée par le logiciel antivirus Avast.
http://www.avast.com

bonjour Emile,

je n'ai pas utilisé le copier / coller dans cette macro,
que veut-tu dire en par "cet objet" ?

isabelle

Le 2015-06-22 08:54, Emile63 a écrit :

Bonjour Isabelle,

Je te remercie pour ton aide :-)
Il manque la fin de la ta proc. (copier / coller à du s'égarer un peu), mais c'est bien ce que je cherchais. :-)

Sans vouloir abuser, est-ce que tu peux m'aider (encore), je souhaiterais faire une boucle sur cet objet et lister tous ses items avec leurs n° de position.

Encore merci pour ta sollicitude.
Cordialement,
Emile

Bonjour,


Une façon de procéder :
Dans la ligne de code suivante de la procédure "TEST",
Tu dois renseigner le chemin de départ où tu veux effectuer un "scan"
pour tous les sous-répertoires concernant le type d'extension de fichier "*.xls"
(à toi d'adapter le type de fichier que tu désires)
Feuil1 est le nom de la feuille où seront copiées les données
B5 est l'adresse de la première cellule à utiliser pour le tableau des résultats.
Nb à ne pas toucher!
Call Remplir "c:UsersTon profilDocuments", "*.xls", "Feuil1", "B5", Nb

Attention, si le répertoire de départ est le "C:", tu veux alors que la procédure examine
tous les sous-répertoires du disque dur, cela risque d'être un peu long!!!

'------------------------------------------------------------------
Sub test()
Application.ScreenUpdating = False
Call Remplir "c:UsersTon profilDocuments", "*.xls", "Feuil1", "B5", Nb
Application.ScreenUpdating = True
End Sub

'------------------------------------------------------------------
Sub Remplir(RepertParent, ExtFichier, NomFeuille, Adr, Nb)
Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String

ExtLocale = ExtFichier
LeFichier = Dir(RepertParent & ExtFichier)
If Len(LeFichier) > 0 Then
' ActiveCell.Value = RepertParent
'ActiveCell.Offset(1, 0).Select
Do While Len(LeFichier) > 0
With Worksheets(NomFeuille)
With .Range(Adr)
.Offset(Nb, 0) = RepertParent
.Offset(Nb, 1) = LeFichier
Nb = Nb + 1
End With
End With
LeFichier = Dir
Loop
End If
'Compter le nombre de sous-répertoires
NbreRepert = 0
LeDossier = Dir(RepertParent, vbDirectory)
Do While LeDossier <> ""
If LeDossier <> "." And LeDossier <> ".." Then
If (GetAttr(RepertParent & LeDossier) And vbDirectory) = vbDirectory Then
NbreRepert = NbreRepert + 1
End If
End If
LeDossier = Dir
Loop
ReDim LeDossierLocal(NbreRepert + 1)
Compteur = 1
LeDossierLocal(Compteur) = Dir(RepertParent, vbDirectory)
Do While LeDossierLocal(Compteur) <> ""
If LeDossierLocal(Compteur) <> "." And LeDossierLocal(Compteur) <> ".." Then
If (GetAttr(RepertParent & LeDossierLocal(Compteur)) And vbDirectory) = vbDirectory Then
Compteur = Compteur + 1
End If
End If
LeDossierLocal(Compteur) = Dir
Loop
For Compteur = 1 To UBound(LeDossierLocal()) - 1
ParentLocal = RepertParent & LeDossierLocal(Compteur) & ""
Call Remplir(ParentLocal, ExtFichier, NomFeuille, Adr, Nb)
Next
End Sub
'------------------------------------------------------------------

Salut
Il me bloque à la 3 ° ligne de sub test (erreur de compil)
Call Remplir "c:Userspcapp dataroamingmicrosoftwindowsstart
menuprogramsgarmin", "*.gdb", "Feuil1", "B5", Nb
------
Pourquoi re-appelles-tu la macro 3 lignes avant la fin?
Call Remplir(ParentLocal, ExtFichier, NomFeuille, Adr, Nb)
------------
Déjà merci
Jacques

Jacquouille

" Le vin est au repas ce que le parfum est à la femme."
"MichD" a écrit dans le message de groupe de discussion :
mm9dd7$tub$1@speranza.aioe.org...

Bonjour,


Une façon de procéder :
Dans la ligne de code suivante de la procédure "TEST",
Tu dois renseigner le chemin de départ où tu veux effectuer un "scan"
pour tous les sous-répertoires concernant le type d'extension de fichier
"*.xls"
(à toi d'adapter le type de fichier que tu désires)
Feuil1 est le nom de la feuille où seront copiées les données
B5 est l'adresse de la première cellule à utiliser pour le tableau des
résultats.
Nb à ne pas toucher!
Call Remplir "c:UsersTon profilDocuments", "*.xls", "Feuil1", "B5", Nb

Attention, si le répertoire de départ est le "C:", tu veux alors que la
procédure examine
tous les sous-répertoires du disque dur, cela risque d'être un peu long!!!

'------------------------------------------------------------------
Sub test()
Application.ScreenUpdating = False
Call Remplir "c:UsersTon profilDocuments", "*.xls", "Feuil1", "B5", Nb
Application.ScreenUpdating = True
End Sub

'------------------------------------------------------------------
Sub Remplir(RepertParent, ExtFichier, NomFeuille, Adr, Nb)
Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String

ExtLocale = ExtFichier
LeFichier = Dir(RepertParent & ExtFichier)
If Len(LeFichier) > 0 Then
' ActiveCell.Value = RepertParent
'ActiveCell.Offset(1, 0).Select
Do While Len(LeFichier) > 0
With Worksheets(NomFeuille)
With .Range(Adr)
.Offset(Nb, 0) = RepertParent
.Offset(Nb, 1) = LeFichier
Nb = Nb + 1
End With
End With
LeFichier = Dir
Loop
End If
'Compter le nombre de sous-répertoires
NbreRepert = 0
LeDossier = Dir(RepertParent, vbDirectory)
Do While LeDossier <> ""
If LeDossier <> "." And LeDossier <> ".." Then
If (GetAttr(RepertParent & LeDossier) And vbDirectory) = vbDirectory
Then
NbreRepert = NbreRepert + 1
End If
End If
LeDossier = Dir
Loop
ReDim LeDossierLocal(NbreRepert + 1)
Compteur = 1
LeDossierLocal(Compteur) = Dir(RepertParent, vbDirectory)
Do While LeDossierLocal(Compteur) <> ""
If LeDossierLocal(Compteur) <> "." And LeDossierLocal(Compteur) <> ".."
Then
If (GetAttr(RepertParent & LeDossierLocal(Compteur)) And
vbDirectory) = vbDirectory Then
Compteur = Compteur + 1
End If
End If
LeDossierLocal(Compteur) = Dir
Loop
For Compteur = 1 To UBound(LeDossierLocal()) - 1
ParentLocal = RepertParent & LeDossierLocal(Compteur) & ""
Call Remplir(ParentLocal, ExtFichier, NomFeuille, Adr, Nb)
Next
End Sub
'------------------------------------------------------------------


---
L'absence de virus dans ce courrier électronique a été vérifiée par le logiciel antivirus Avast.
http://www.avast.com

Bonjour,

A )
il manque des parenthèses comme ceci et sur
une seule ligne

**** Call Remplir ("c:Userspcapp dataroamingmicrosoftwindowsstart menuprogramsgarmin",
"*.gdb", "Feuil1", "B5", Nb)

B )
Pourquoi re-appelles-tu la macro 3 lignes avant la fin?
Call Remplir(ParentLocal, ExtFichier, NomFeuille, Adr, Nb)

**** Pour pouvoir boucler sur tous les sous-répertoires du répertoire principal.

Hello
J'ai modifié comme suggéré. Impec. Elle ne bloque plus.
Mais, la macro se déroule en un centième de sec, comme s'il n'y avait rien à
chercher, nulle part
J'ai mis un msgbox juste avant la ligne end sub. La macro y arrive mais ne
copie rien....
Désolé que je suis. Pourtant, je devrais avoir une trentaine de fichiers.

Jacquouille

" Le vin est au repas ce que le parfum est à la femme."
"MichD" a écrit dans le message de groupe de discussion :
mm9q8c$36p$1@speranza.aioe.org...

Bonjour,

A )
il manque des parenthèses comme ceci et sur
une seule ligne

**** Call Remplir ("c:Userspcapp dataroamingmicrosoftwindowsstart
menuprogramsgarmin",
"*.gdb", "Feuil1", "B5", Nb)

B )
Pourquoi re-appelles-tu la macro 3 lignes avant la fin?
Call Remplir(ParentLocal, ExtFichier, NomFeuille, Adr, Nb)

**** Pour pouvoir boucler sur tous les sous-répertoires du répertoire
principal.


---
L'absence de virus dans ce courrier électronique a été vérifiée par le logiciel antivirus Avast.
http://www.avast.com