Untitled diff
Criado O diff nunca expira
34 remoções
| Linhas | |
|---|---|
| Total | |
| Removido | |
| Caracteres | |
| Total | |
| Removido | |
32 adições
| Linhas | |
|---|---|
| Total | |
| Adicionado | |
| Caracteres | |
| Total | |
| Adicionado | |
Sub FileList()
Sub FileList()
Dim V As String
Dim V As String
Dim BrowseFolder As String
Dim BrowseFolder As String
'открываем диалоговое окно выбора папки
'открываем окно выбора папки
With Application.FileDialog(msoFileDialogFolderPicker)
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Выберите папку или диск"
.Title = "Оберіть папку/диск"
.Show
.Show
On Error Resume Next
On Error Resume Next
Err.Clear
Err.Clear
V = .SelectedItems(1)
V = .SelectedItems(1)
If Err.Number <> 0 Then
If Err.Number <> 0 Then
MsgBox "Вы ничего не выбрали!"
MsgBox "Нічого не обрано!"
Exit Sub
Exit Sub
End If
End If
End With
End With
BrowseFolder = CStr(V)
BrowseFolder = CStr(V)
'добавляем лист и выводим на него шапку таблицы
'добавляем лист и выводим в него шапку таблицы
ActiveWorkbook.Sheets.Add
Sheets("Information").Select
Worksheets("Information").Range("A1:E" & Range("A65536").End(xlUp).Row).ClearContents
With Range("A1:E1")
With Range("A1:E1")
.Font.Bold = True
.Font.Bold = True
.Font.Size = 12
.Font.Size = 12
End With
End With
Range("A1").Value = "Имя файла"
Range("A1").Value = "ім'я файлу"
Range("B1").Value = "Путь"
Range("B1").Value = "розташування"
Range("C1").Value = "Размер"
Range("C1").Value = "розмір"
Range("D1").Value = "Дата создания"
Range("D1").Value = "дата створення"
Range("E1").Value = "Дата изменения"
Range("E1").Value = "дата зміни"
'вызываем процедуру вывода списка файлов
'вызов процедуры вывода списка, если надо - true
'измените True на False, если не нужно выводить файлы из вложенных папок
ListFilesInFolder BrowseFolder, False
ListFilesInFolder BrowseFolder, True
End Sub
End Sub
Private Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubFolders As Boolean)
Private Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim FSO As Object
Dim FSO As Object
Dim SourceFolder As Object
Dim SourceFolder As Object
Dim SubFolder As Object
Dim SubFolder As Object
Dim FileItem As Object
Dim FileItem As Object
Dim r As Long
Dim r As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.getfolder(SourceFolderName)
Set SourceFolder = FSO.getfolder(SourceFolderName)
r = Range("A65536").End(xlUp).Row + 1 'находим первую пустую строку
r = Range("A65536").End(xlUp).Row + 1 'находиим 1ю пустую строку
'выводим данные по файлу
'выводим данные по файлу
For Each FileItem In SourceFolder.Files
For Each FileItem In SourceFolder.Files
Cells(r, 1).Formula = FileItem.Name
Cells(r, 1).Formula = FileItem.Name
Cells(r, 2).Formula = FileItem.Path
Cells(r, 2).Formula = FileItem.Path
Cells(r, 3).Formula = FileItem.Size
Cells(r, 3).Formula = FileItem.Size
Cells(r, 4).Formula = FileItem.DateCreated
Cells(r, 4).Formula = FileItem.DateCreated
Cells(r, 5).Formula = FileItem.DateLastModified
Cells(r, 5).Formula = FileItem.DateLastModified
r = r + 1
r = r + 1
X = SourceFolder.Path
X = Source.Folder.Path
Next FileItem
Next FileItem
'вызываем процедуру повторно для каждой вложенной папки
'повторная процедура для каждой вложенной папки
If IncludeSubfolders Then
If IncludeSubFolders Then
For Each SubFolder In SourceFolder.SubFolders
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
ListFilesInFolder SubFolder.Path, True
Next SubFolder
Next SubFolder
End If
End If
Columns("A:E").AutoFit
Columns("A:E").AutoFit
Set FileItem = Nothing
Set FileItem = Nothing
Set SourceFolder = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
Set FSO = Nothing
End Sub
End Sub