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

Ce n'est pas un problème avec la macro, mais probablement le répertoire dans lequel
se retrouvent tes fichiers.

Es-tu certain que ce répertoire existe : "app data", ne serait-ce pas plutôt "appdata" ?

A ) c:Userspcapp data -> AppData est un répertoire masqué que l'on doit rendre visible
en utilisant l'explorateur Windows / Options / options des dossiers / onglet affichage /
et coché l'item suivant : "Afficher les fichiers, dossiers et lecteurs cachés"

B ) Teste la macro en créant dans le répertoire "Document" de ton profil, des fichiers ayant
l'extension .gdb . Est-ce que la macro les extrait? Si oui, tu as de la difficulté avec Windows
et non avec la macro.

... et pour finir, voici la bonne ligne
Call Remplir("c:garmin", "*.gdb", "Feuil1", "B5", Nb)
Ce que je ne comprends pas, car quand je clique sur les propriétés d'un
fichier, il me met toute la ligne ..(chemin archi complet)

Encore un truc.... en col B, il me met........ c:garmin
et le nom du fichier en col C........ Chantoirs Roche faucons.gdb
Enfin, le boulot est fait.
----------
J'ai repris ta macro de 2012 (sub ZAZA reprise sur Excelabo) et adapté comme
suit:
Et ça fait le job aussi, comme vous dites là-bas.
Donc, 2 macos pour le prix d'une.
Grand merci à toi
Bonne fin de journée
Jacques.
-----------------
Sub Chercher_ext_gdb()
Set fs = Application.FileSearch
With fs
.LookIn = "C:garmin"
.Filename = "*gdb"
.Execute
For i = 1 To .FoundFiles.Count
Range("a" & i).Value = .FoundFiles(i)
Next i
If .FoundFiles.Count = 0 Then
MsgBox "Aucun fichier n'a été trouvé."
End If
End With
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 Isabelle,

Oui je voulais simplement dire que la proc. que tu m'as proposée correspo nd bien à ce que je souhaitais, cependant telle quelle elle bloque. Il ma nquant la fin pour son exécution, que j'ai complétée, voilà pourquo i j'ai pensé à un copier/coller incomplet.. ;-)
(ça m'arrive parfois quand je copie de VBA sur Groups.Google d'oublier u n bout)
........................
End If
Next
End Sub
-------------------------
D'autre part, comme je l'avais souhaité tu m'a proposé les items 0,1,4, 20

Mais je me demandais combien est-ce qu'il y en avait en tout et surtout, ta nt qu'à faire, si d'autre pouvaient également m'être utiles. D'ou ma demande d'une boucle pour les connaitre et les identifier.
Merci encore pour ta sollicitude.
Emile

Bonjour MichD,

Merci pour ta solution.
Je l'ai testée et j'obtiens 34 colonnes. Mais je n'y vois pas celle qui s 'appelle "Etat" (Propriétés du document: État ) qui pourrait m'être bien utile également. ;-)
J'ai rallongé la proc. d'Isabelle jusqu'à 30 items(0-30), histoire de v oir si l'"état" apparaîtrait par là au milieu, mais non. :-(

| Je l'ai testée et j'obtiens 34 colonnes.

**** Avec l'approche proposée, il n'y en a pas plus!

Cependant, tu peux utiliser la collection "BuiltinDocumentProperties" d'un objet "Workbook".
Tu vas obtenir la liste des propriétés de base documents "Microsoft Office".

Pour obtenir la valeur des propriétés d'un classeur, ce dernier doit être ouvert.
Et, dans la procédure, au lieu d'utiliser l'expression Thisworkbook qui signifie le
classeur actif, on peut employer "Workbooks("NomDuClasseur.xlsm") ou encore
une variable de type Workbook

Dim Wk As Workbook
'si le classeur n'est pas ouvert
set Wk = Workbooks.open(Chemin & nom du fichier à ouvrir)
'Si le classeur est ouvert
Set Wk = Workbooks("NomDuClasseur.xlsm")
For each P In Wk.BuiltinDocumentProperties
'..../
Next

'-----------------------------------------------------
Sub test()
Dim P As Variant, A As Integer
For Each P In ThisWorkbook.BuiltinDocumentProperties
A = A + 1
Range("A" & A) = P.Name
Next
End Sub
'-----------------------------------------------------

La propriété "État" à laquelle tu réfères ne fait pas partie de cette liste. Cependant, tu peux
l'extraire de cette manière :
x = ThisWorkbook.BuiltinDocumentProperties("Content Status")

Merci MichD pour ce complément d'information et cette proposition.
Malheureusement l'approche que tu m'indiques (classeur ouvert), ça ne va pas le faire...
Je me contenterai de ce que j'ai déjà.
Merci quand même et très bonne journée.

Emile

ha! ok,

tu as la liste ici: https://technet.microsoft.com/library/ee176615.aspx
les différents type de fichier ne répondent pas tous aux 34 propriétés

isabelle

Ok, Super.
merci Isabelle :-)

Bonjour Isabelle,
Je reviens sur cette procédure que tu m'avais gentiment mise à disposit ion, car très efficace au début, elle à beaucoup ralenti son temps d' exécution dernièrement (pour une raison que j'ignore) et aujourd'hui el le "plante Excel" avec le message d'erreur suivant:
"Excel ne peut pas terminer cette tâche avec les ressources disponibles.
Sélectionnez moins de données ou fermez des applications"

Evidemment cet avertissement n'est pas très explicite, car même Excel s eul (sans aucune autre application) dans Windows (7) le message arrive et f ini par planter. En réalité il y a en tout une trentaine de fichiers qu e je "scanne" dans le répertoire et rapatrie les items.

J'ai pensé que ce code doit partir en boucle quelque part, mais en le pas sant en pas à pas, je ne le détecte pas. Bien que si je fais un pas à pas énergique, il plante pareille.

Est-ce qu'un oeil expert saurait me dire comment lui donner un peu d'oxyg ène, et agiliser son fonctionnement

'CODE:
'---------------------------------------------------------
Sub ListeProprietesFichiers_getDetailsOfTest()
'Nécessite d'activer la référence Microsoft Shell Controls and A utomation
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
Dim Racine As String
Dim MaCellule As String

On Error Resume Next
MaCellule = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute: =False)
With Application
.StatusBar = "Exécution macro...."
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
Racine = ChoixDossierII()
If Racine = "" Then Exit Sub
Range("A:I").Clear
Range("A1").Select

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

'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, 3)
Cells(1, 4) = objFolder.GetDetailsOf(objFolder.Items, 18)
Cells(1, 5) = objFolder.GetDetailsOf(objFolder.Items, 20)
Cells(1, 6) = objFolder.GetDetailsOf(objFolder.Items, 21)
Cells(1, 7) = objFolder.GetDetailsOf(objFolder.Items, 22)
Cells(1, 8) = objFolder.GetDetailsOf(objFolder.Items, 23)
Cells(1, 9) = objFolder.GetDetailsOf(objFolder.Items, 24)

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, 3)
Cells(x, 4) = objFolder.GetDetailsOf(strFileName, 18)
Cells(x, 5) = objFolder.GetDetailsOf(strFileName, 20)
Cells(x, 6) = objFolder.GetDetailsOf(strFileName, 21)
Cells(x, 7) = objFolder.GetDetailsOf(strFileName, 22)
Cells(x, 8) = objFolder.GetDetailsOf(strFileName, 23)
Cells(x, 9) = objFolder.GetDetailsOf(strFileName, 24)
End If
End If
Next
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Font
.Name = "Verdana"
.Size = 10
End With
With ActiveWindow
.SplitRow = 1
.FreezePanes = True
.DisplayGridlines = False
End With
Range(Selection, Selection.End(xlDown)).Select
With Selection
.Locked = False
.AutoFilter
End With
Columns("A:H").AutoFit
Columns("B:H").HorizontalAlignment = xlCenter
Columns("F:G").EntireColumn.Hidden = True
With Application
.Goto Reference:=ActiveSheet.Range("A1"), scroll:=True
.Range(MaCellule).Select
.DisplayAlerts = True
.StatusBar = False
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function ChoixDossierII()
If Val(Application.Version) >= 10 Then
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:DocumentsMes Dossiers"
.Show
If .SelectedItems.Count > 0 Then
ChoixDossierII = .SelectedItems(1)
Else
ChoixDossierII = ""
End If
End With
Else
ChoixDossierII = InputBox("Confirmer le répertoire?")
End If
End Function
'---------------------------------------------------------
Merci d'avance pour votre aide et éventuelles idées / solutions.

Cordialement,

Emile

Bonjour,

Au tout début de la procédure avant la ligne "On error resume next", ajoute
ces 2 lignes de code :

Application.EnableEvents = False
Application.ScreenUpdating = False