Re : Récupérer noms de dossier et de fichier
bonjour et salutatous,
j'ai modifié ta macro en y ajoutant une référence à DSO
il faut donc activer la référence DSO OleDocument Properties Reader 2.0
Les propriétés de DSO.SummaryProperties sont :
ApplicationName ' Author ' ByteCount ' Category ' CharacterCount
CharacterCountWithSpaces ' Comments ' Company ' DateCreated
DateLastPrinted ' DateLastSaved ' HiddenSlideCount
Keywords ' LastSavedBy ' LineCount ' Manager ' MultimediaClipCount
NoteCount ' PageCount ' ParagraphCount ' PresentationFormat
RevisionNumber ' SharedDocument ' SlideCount
Subject ' Template ' Title ' TotalEditTime ' Version ' WordCount
Sub MainExtractData()
'Nécessite d'activer la référence DSO OleDocument Properties Reader 2.0
Dim DSO As DSOFile.OleDocumentProperties
Set DSO = New DSOFile.OleDocumentProperties
Dim NewSht As Worksheet
Dim MainFolderName As String
Dim TimeLimit As Long, StartTime As Double
ReDim X(1 To 65536, 1 To 12)
Set objShell = CreateObject("Shell.Application")
TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" & vbNewLine & vbNewLine & _
"Leave this at zero for unlimited runtime", "Time Check box", 0)
StartTime = Timer
Application.ScreenUpdating = False
MainFolderName = BrowseForFolder()
Set NewSht = ThisWorkbook.Sheets.Add
X(1, 1) = "Path"
X(1, 2) = "File Name"
X(1, 3) = "Last Accessed"
X(1, 4) = "Last Modified"
X(1, 5) = "Created"
X(1, 6) = "Date Dernier enregistrement"
X(1, 7) = "Type"
X(1, 8) = "Size"
X(1, 9) = "Owner"
X(1, 10) = "Author"
X(1, 11) = "Title"
X(1, 12) = "Comments"
i = 1
Set fso = CreateObject("scripting.FileSystemObject")
Set oFolder = fso.GetFolder(MainFolderName)
'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
On Error Resume Next
For Each Fil In oFolder.Files
Set objFolder = objShell.Namespace(oFolder.Path)
Set objFolderItem = objFolder.ParseName(Fil.Name)
i = i + 1
If i Mod 20 = 0 And TimeLimit <> 0 And Timer > (TimeLimit * 60 + StartTime) Then
GoTo FastExit
End If
If i Mod 50 = 0 Then
Application.StatusBar = "Processing File " & i
DoEvents
End If
X(i, 1) = oFolder.Path
X(i, 2) = Fil.Name
X(i, 3) = Fil.DateLastAccessed
X(i, 4) = Fil.DateLastModified
'X(i, 5) = Fil.DateCreated
'X(i, 6) = Fil.DateLastsaved
X(i, 7) = Fil.Type
X(i, 8) = Fil.Size
X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 8)
X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 9)
X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 10)
X(i, 12) = objFolder.GetDetailsOf(objFolderItem, 14)
DSO.Open sfilename:="" & oFolder.Path & "\" & Fil.Name
X(i, 5) = DSO.SummaryProperties.DateCreated
X(i, 6) = DSO.SummaryProperties.DateLastSaved
Next
'Get subdirectories
If TimeLimit = 0 Then
Call RecursiveFolder(oFolder, 0)
Else
If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
End If
FastExit:
Range("A:K") = X
If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
Range("A:K").WrapText = False
Range("A:K").EntireColumn.AutoFit
Range("1:1").Font.Bold = True
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Range("a1").Activate
Set fso = Nothing
Set objShell = Nothing
Set oFolder = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set Fil = Nothing
DSO.Close
Application.StatusBar = ""
Application.ScreenUpdating = True
End Sub
+a
