Récupérer en variable les pieds de page d'une feuille d'un classeur fermé

[fb62840]

Bonjour à toutes et à tous,

Je cherche à obtenir par macro vba les différents éléments contenus dans le pied de page d'un classeur "fermé" (en fait il faut l'ouvrir pour aller chercher les différentes parties du pied de page, mais je ne souhaite pas que l'utilisateur le constate).

Cette partie de code est à insérer dans une macro qui permet de lister l'ensemble des dossiers et fichiers d'un lecteur.

Je suis parvenu à obtenir lorsqu'il s'agit d'un document word le pied de page (mais il reste quelques cas problématiques erreur de type 5981, ouverture en copie quand le document est en cours d'utilisation), si vous pouvez également m'aider à optimiser le code pour gérer ces cas, ce serait génial.

Voici le code de la macro :

' d'après Ole P Erlandsen
' code original à cette adresse http://www.erlandsendata.no/)

Sub TestListFilesInFolder()
Dim RootFolder$
RootFolder = ChoisirDossier
If RootFolder = "" Then Exit Sub

Workbooks.Add
With Range("A1")
    .Formula = " Root Folder : " & RootFolder
End With
Range("A3").Formula = "Chemin : "
Range("B3").Formula = "Nom du fichier : "
Range("C3").Formula = "Type de fichier : "
Range("D3").Formula = "Date d'écriture sur le répertoire : "
Range("E3").Formula = "Date du dernier accès : "
Range("F3").Formula = "Date de la dernière modification :"
Range("G3").Formula = "Chemin d'accès réel :"

With Range("A3:C3")
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
    .ColumnWidth = 30
End With

With Range("D3:F3")
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
    .ColumnWidth = 17
    .WrapText = True
End With

With Range("G3")
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
    .ColumnWidth = 30
    .WrapText = True
End With


ListFilesInFolder RootFolder, True

Cells.Select
    With Selection
        .WrapText = True
    End With
End Sub

__________________________________________________________________________

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' Ole P Erlandsen (modifié fs 11/8/01)
Dim FSO 'As Scripting.FileSystemObject
Dim SourceFolder 'As Scripting.Folder
Dim SubFolder 'As Scripting.Folder
Dim FileItem 'As Scripting.File
Dim r As Long
Dim lien As String
Dim Fichier
Dim xl
Dim strRev

Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
r = Range("A65536").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
    ' display file properties
    Cells(r, 1).Formula = FileItem.ParentFolder
    Cells(r, 2).Formula = FileItem.Name
    Cells(r, 3).Formula = FileItem.Type
    Cells(r, 4).Formula = FileItem.DateCreated
    Cells(r, 4).NumberFormatLocal = "jj/mm/aa"
    Cells(r, 5).Formula = FileItem.DateLastAccessed
    Cells(r, 5).NumberFormatLocal = "jj/mm/aa"
    Cells(r, 6).Formula = FileItem.DateLastModified
    Cells(r, 6).NumberFormatLocal = "jj/mm/aa"
    lien = Cells(r, 1).Value & "\" & Cells(r, 2)
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 7), _
    Address:=FileItem.ParentFolder & "\" & FileItem.Name

    Application.ScreenUpdating = False
    On Error GoTo PseudoErreur
    
'Cette partie de code renvoit une erreur
    'If FileItem.Type = "Feuille de calcul Microsoft Excel" Then
       ' chemin = FileItem.ParentFolder
        'Fichier = FileItem.Name
       ' Set xl = CreateObject("Excel.application")
        'xl.Visible = False
        'Set Mondoc = xl.Documents.Open(chemin & "\" & Fichier)
        'ActiveSheet.PageSetup
        'strRev = ActiveSheet.PageSetup.LeftFooter
        
    Cells(r, 8).Formula = strRev
    Mondoc.Close False
    xl.Quit
    Set xl = Nothing

'cette partie de code me permet de récupérer la quasi totalité des pieds de page, mais 'j'aimerais que soit géré automatiquement le cas de l'ouverture en copie sans que 'l'utilisateur voie le message et sans qu'il ait à cliquer sur Ok pour ouvrir en copie
'If FileItem.Type = "Document Microsoft Word" Then
       chemin = FileItem.ParentFolder
       Fichier = FileItem.Name
       Set wd = CreateObject("Word.application")
       wd.Visible = False
       Set Mondoc = wd.Documents.Open(chemin & "\" & Fichier)
       'Cells(r, 8).Formula = Left(Mondoc.Sections(1).Footers(1), Len(Mondoc.Sections(1).Footers(1)) - 1)
       Mondoc.Close False
       'wd.Quit
       'Set wd = Nothing
       'Mondoc.Close False
       'wd.Quit
       Set wd = Nothing
End If
    r = r + 1
Next FileItem
If IncludeSubfolders Then
    For Each SubFolder In SourceFolder.SubFolders
     ListFilesInFolder SubFolder.Path, True
    Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True

PseudoErreur:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox Err.Number & vbCrLf & Err.Description

End Sub
__________________________________________________________________________

Private Function ChoisirDossier()
Dim objShell, objFolder, chemin, SecuriteSlash
                                            
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = _
        objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
    On Error Resume Next
    chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
    If objFolder.Title = "Bureau" Then
        chemin = "C:\Windows\Bureau"
    End If
    If objFolder.Title = "" Then
        chemin = ""
    End If
    SecuriteSlash = InStr(objFolder.Title, ":")
    If SecuriteSlash > 0 Then
        chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
    End If
    ChoisirDossier = chemin
End Function

Merci pour vos conseils et votre aide.