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 :
Merci pour vos conseils et votre aide.
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 :
Code:
' 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.