VBA Excel: Récupérer les propriétés de Word Résolu/Fermé

Question

Bonjour, 

Je tente de faire un programme en VBA permettant d'inscrire les propriétés des fichiers Word contenus dans un répertoir dans un tableau Excel. Les propriétés ciblées sont Titre, Auteur, Mots Clés, Nom, Nom Fichier et Créé le.

Dans un premier temps je voudrais tester le programme sur un fichier seul et récupérer n'importe quelle propriété.

Voici mon code (qui ne fonctionne pas...)


Sub testtt() 'affichage des propriété d'un fichier ds cellules excel
    Dim objDoc As Word.Document, msg As String
    Dim rw As Integer
    rw = 1
    Set objDoc = Application.Documents.Open(ChoiFich)
    For Each p In objDoc.BuiltinDocumentProperties
        Worksheets("Feuil1").Cells(rw, 1).Value = p.Name
        rw = rw + 1
    Next
End Sub


Et voici ChoiFich, qui permet de sélectionner le fichier:

Function ChoiFich() As String 'Choix d'un fichier + Renvoi de son chemin d'accès
  Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = False
  Application.FileDialog(msoFileDialogFilePicker).Show
  ChoiFich = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
End Function



Quelqu'un aurait-il une solution ?



Je voulais par la même occasion savoir comment déclarer dans le code les références supplémentaires à activer pour utiliser le programme (pour éviter les erreurs lors de l'utilisation sur un autre ordinateur).

Merci.
Configuration: Windows XP / Internet Explorer 7.0

michel_m · Accepted Answer

Bonjour, 

avec la bibkiothèque FSO tu n'as pas besoin d'ouvrir le doc 

macros de silkyroad sur DVP (j'ai supprimmé l'activation de la dll " scripting runtime" par la création de l'objet scripting.FSO). ce code est valable sur tout type de fichiers 
sourceDVP:
https://silkyroad.developpez.com/VBA/ProprietesClasseurs/#LIV

Sub Test() 
    proprietesFichier_getFile "D:\Documents\doc1.doc" 
End Sub 


Sub proprietesFichier_getFile(Fichier As String) 
    Dim cible As Object 
    Dim valeur As Object 
    Dim Resultat As String 
     
    Set cible = CreateObject("Scripting.fileSystemObject") 
    Set valeur = cible.GetFile(Fichier) 
     
    Resultat = "Chemin et nom complet : " & cible.GetAbsolutePathName(valeur) & Chr(10) & Chr(10) & _ 
    "Chemin : " & cible.GetParentFolderName(valeur) & Chr(10) & Chr(10) & _ 
    "Nom fichier : " & cible.GetFileName(valeur) & Chr(10) & Chr(10) & _ 
    "Nom fichier sans extension : " & cible.GetBaseName(valeur) & Chr(10) & Chr(10) & _ 
    "Extension fichier : " & cible.GetExtensionName(valeur) & Chr(10) & Chr(10) & _ 
    "Chemin : " & valeur.ParentFolder & Chr(10) & Chr(10) & _ 
    "Chemin court : " & valeur.shortpath & Chr(10) & Chr(10) & _ 
    "Nom court : " & valeur.ShortName & Chr(10) & Chr(10) & _ 
    "Date creation : " & valeur.dateCreated & Chr(10) & Chr(10) & _ 
    "Derniere modification : " & valeur.dateLastModified & Chr(10) & Chr(10) & _ 
    "Taille fichier : " & valeur.Size & " octets" & Chr(10) & Chr(10) & _ 
    "Type fichier : " & valeur.Type 

    MsgBox Resultat 

End Sub
Michel

Galgante · Answer

Après relecture des sources que tu m'as indiqué, je suis arrivé à ça: 


Sub RaffraichirBDD() 
    ' 
    '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 i As Byte 
    Dim flag As Integer 'drapeau 
     
    Set objShell = CreateObject("Shell.Application") 
    'Répertoire cible 
    Set objFolder = objShell.Namespace(ChoiDoss) 
     
    flag = 0 
    'boucle sur tous les elements du repertoire 
    For Each strFileName In objFolder.Items 
         
        'Pour que les dosssiers ne soient pas pris en comptes 
        If strFileName.IsFolder = False Then 
            For i = 0 To 15 
                If flag <> 0 Then 
                    Worksheets("Feuil1").Cells(ligne, i + 1) =_ objFolder.GetDetailsOf(strFileName, i) 
                Else 
                    ligne = 1 
                    Worksheets("Feuil1").Cells(ligne, i + 1) =_ objFolder.GetDetailsOf(objFolder.Items, i) 
                    ligne = 2 
                    Worksheets("Feuil1").Cells(ligne, i + 1) =_ objFolder.GetDetailsOf(strFileName, i) 
                End If 
            Next 
            flag = 1 
            ligne = ligne + 1 
        End If 
    Next 
End Sub 


J'avais besoin des propriétés avancées des fichiers. 

Cordialement.