|
Обладатели MS Excel 2007 (и старше) могут использовать следующие
варианты I, II, IV, VI, VII и V (только 32-bit)
Предисловие :
При работе в MS Excel (и не только) частенько возникает необходимость
в переборе всех (или только с определённым расширением) файлов, в
конкретной папке, иногда требуется не только перебрать файлы, но и
подсчитать их количество. Решения таких задач можно найти в FAQ, но
они разбросаны по разным разделам, в этой же заметке они собраны вместе,
кроме того, добавлены ещё несколько вариантов, которые, по разным причинам
не успели попасть в FAQ.
Обратите внимание на то, что у каждого способа есть свои особенности,
которые желательно учитывать при выборе наиболее подходящего и работе с ним.
Впрочем, есть у них и кое-что общее, а именно нечувствительность
к регистру символов, т.е. при указании папки, Вы можете использовать как
строчные, так и прописные буквы, проще говоря, все три нижеприведённые
строки допустимы :
"C:\мои документы\"
"C:\Мои Документы\"
"C:\МОИ ДОКУМЕНТЫ\"
Вариант I.
Для перебора файлов и их подсчёта, можно использовать функцию
Dir
| Private Sub Example_Dir()
iPath$ = "C:\Мои документы\"
iFileName$ = Dir(iPath$)
Do While iFileName$ <> ""
iCount& = iCount& + 1
iFileName$ = Dir
Loop
MsgBox "Файлов в папке = " & iCount&
End Sub |
Особенности :
Папку обязательно нужно указывать с завершающим слэшем \
Если Вы забудете указать папку, т.е. iPath$ = ""
то перебор файлов, скорее всего, будет осуществляться
в текущей папке [FAQ415] , если при первом вызове функции
Dir Вы вообще не укажите путь, то возникнет ошибка.
Функция возвращает только имя файла, для получения же
полного имени, например, для открытия рабочей книги, необходимо
об'единить iPath & iFileName
Функция Dir, по умолчанию, игнорирует файлы с атрибутами
Скрытый и/или Только для чтения, однако, если подобные файлы
должны участвовать в переборе/подсчёте, то для этого необходимо
использовать второй необязательный аргумент и соответствующие
константы vbHidden + vbReadOnly (см. второй пример)
Функция Dir допускает использование символов подстановки ?
(один единственный символ) (см. третий пример) и *
(любое количество символов, в т.ч. и 0), которые позволяют
перебирать только файлы по-маске, в т.ч. и с определённым расширением
(см. остальные примеры)
Private Sub Example2_Dir()
iPath$ = "C:\Мои документы\"
iFileName$ = Dir(iPath$, vbHidden + vbReadOnly)
Do While iFileName$ <> ""
iCount& = iCount& + 1
iFileName$ = Dir
Loop
MsgBox "Файлов в папке = " & iCount&
End Sub |
| Private Sub Example3_Dir()
iPath$ = Application.LibraryPath
iFileName$ = Dir(iPath$ & "\*.xl?")
Do While iFileName$ <> ""
iCount& = iCount& + 1
iFileName$ = Dir
Loop
MsgBox "Файлов с расширением .XL = " & iCount&
End Sub |
| Private Sub Example4_Dir()
iPath$ = Application.Path & "\"
iFileName$ = Dir(iPath$ & "*.EXE")
Do While iFileName$ <> ""
iCount& = iCount& + 1
iFileName$ = Dir
Loop
MsgBox "Файлов с расширением .exe = " & iCount&
End Sub |
| Private Sub Example5_Dir()
iPath$ = Application.Path
iFileName$ = Dir(iPath$ & "\MSO*")
Do While iFileName$ <> ""
iCount& = iCount& + 1
iFileName$ = Dir
Loop
MsgBox "Файлов начинающихся с MSO = " & iCount&
End Sub |
| Private Sub Example6_Dir()
iPath$ = Application.DefaultFilePath
iFileName$ = Dir(iPath$ & "\Список*.txt")
If iFileName$ <> "" Then
Do
iCount& = iCount& + 1
iFileName$ = Dir
Loop Until iFileName$ = ""
MsgBox _
"Текстовых файлов, начинающихся со слова Список = " & iCount&
Else
MsgBox "Нужных текстовых файлов нет"
End If
End Sub |
| Private Sub Example7_Dir()
iPath$ = Application.DefaultFilePath
For Each iExtension In Array("jp*g", "gif", "png", "tif", "bmp")
iFileName$ = Dir(iPath$ & "\*." & iExtension)
Do Until iFileName$ = ""
iCount& = iCount& + 1
iFileName$ = Dir
Loop
Next
MsgBox "Картинок с указанными расширениями = " & iCount&
End Sub |
Комментарий : Если Вам необходимо только подсчитать количество
файлов в папке, причём без цикла, то используйте другие варианты.
Вариант II.
Для перебора всех файлов и подсчёта этих файлов, можно также
использовать функцию ФАЙЛЫ (макроязык Excel4.0) К сожалению,
даже при наличии нескольких файлов в папке, вызов этой функции с помощью
ExecuteExcel4Macro , позволяет получить только один файл.
Сомневающиеся в справедливости этого утверждения могут проверить
и убедиться в этом, что называется, воочию :
| Dim iFiles As Variant
iFiles = ExecuteExcel4Macro("FILES()") |
|
iFiles = ExecuteExcel4Macro("FILES(""C:\Мои документы\*"")")
|
Поэтому, для получения списка файлов, нам придётся прибегнуть к небольшому
трюку, а именно создать именованную формулу, вычислить её, а затем удалить.
Совет : Если в текущей рабочей книге создавать список
файлов предполагается постоянно, то однажды созданную формулу можно не
удалять, а просто использовать её в дальнейшем, в т.ч. и вызывая из
ячеек рабочего листа, а если существует вероятность её удаления вручную,
то именованную формулу можно скрыть. Более подробно смотрите
здесь ...)
| Private Sub Example_XLMFiles()
Dim iPath$, iArray As Variant, iFileName As Variant
iPath = "C:\Мои документы\*"
ThisWorkbook.Names.Add Name:= _
"ListFiles", RefersTo:="=Files(""" & iPath & """)"
iArray = Evaluate("ListFiles")
If IsArray(iArray) = True Then
MsgBox "В папке файлов = " & UBound(iArray)
For Each iFileName In iArray
'MsgBox iFileName
Next
Else
MsgBox "В папке нет файлов, или нет папки"
End If
ThisWorkbook.Names("ListFiles").Delete
End Sub |
| Private Sub Example2_XLMFiles()
Dim iPath$, iFileName$, iFullName$
Dim iCounter&, iCount&, iArray As Variant
iPath = "C:\Мои документы\"
ActiveWorkbook.Names.Add Name:= _
"ListFiles", RefersTo:="=Files(""" & iPath & "*"")"
iArray = [ListFiles] 'Evaluate("ListFiles")
If IsArray(iArray) = True Then
iCount = UBound(iArray)
MsgBox "В папке файлов = " & iCount
For iCounter = 1 To iCount
iFileName = iArray(iCounter) 'CStr(iArray(iCounter))
iFullName = iPath & iFileName
Next
Else
MsgBox "В папке нет файлов, или нет папки"
End If
ActiveWorkbook.Names("ListFiles").Delete
End Sub |
Особенности :
Для получения всех файлов - папку обязательно нужно указывать
с завершающим слэшем и символом подстановки \* (за исключением
следующего пункта)
Если Вы не укажите папку, т.е. =Files() то функция возвратит
файлы из текущей папки [FAQ415]
Функция возвращает только имя файла
Функция Files игнорирует файлы с атрибутами Скрытый ,
однако, учитывает файлы Только для чтения
Функция Files также допускает использование символов подстановки
? и * (более подробно смотрите особенности функции Dir)
К сожалению, подобным способом, можно получить максимум 256 файлов
Вариант III. (актуально только для Office97-2003)
Application.FileSearch - довольно мощный
инструмент по поиску файлов, причём не только по имени или расширению,
но и по содержимому документов, времени его создания, изменения, и
многим другим свойствам, впервые появился в MS Office 97 и
закончил своё существование в MS Office 2003
В следующих версиях он также наличествует, но его вызов
заблокировали разработчики, поэтому попытка протестировать все
нижеопубликованные примеры, неизменно приведёт к появления следующей
ошибки
Run-time error '445': Object doesn't support this action
Перечислить все его плюсы и минусы, вряд ли возможно в
небольшой заметке, тем более, что в MS Office XP его возможности
увеличились, но несколько примеров прилагается.
[1] Поиск всех файлов, включая скрытые и только для
чтения, в папке C:\Мои документы и во всех вложенных папках, а также
создание списка этих файлов в первом столбце новой рабочей книги.
Private Sub Example_AppFileSearch()
iPath$ = "C:\Мои документы"
Workbooks.Add xlWBATWorksheet
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = iPath$
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles
For iCount& = 1 To .Execute
Cells(iCount&, 1).Value = .FoundFiles(iCount&)
Next
With Columns(1)
.AutoFit
.Sort _
Key1:=Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With
'MsgBox "Количество найденных файлов = " & iCount&
MsgBox "Кол-во найденных файлов = " & .FoundFiles.Count
End With
Application.ScreenUpdating = True
End Sub |
Примечание : Подсчитать количество найденных файлов можно
и без цикла, для этого достаточно использовать свойство Count
об'екта FoundFiles или результат, который возвращает
функция Execute
[2] Поиск файлов только с расширениями .xls и .doc
(включая скрытые и только для чтения) в папке C:\Мои документы
(и во всех вложенных папках), создание списка найденных файлов,
а также их сортировка(группировка), исходя из типа.
| Private Sub Example2_AppFileSearch()
Dim iPath$, iCount&, iFindFiles As FoundFiles
iPath = "C:\Мои документы\"
Workbooks.Add xlWBATWorksheet
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = iPath
.SearchSubFolders = True
.FileName = "*.xls;*.doc" '".xls;.doc" - Excel97
'.FileType = msoFileTypeAllFiles
.Execute SortBy:=msoSortByFileType
Set iFindFiles = .FoundFiles
For iCount = 1 To iFindFiles.Count
Cells(iCount, 1) = iFindFiles(iCount)
Next
End With
Application.ScreenUpdating = True
End Sub |
[3] Поиск файлов только с расширением .xls
(включая скрытые и только для чтения) в нескольких папках, а именно
C:\Мои документы и D:\Примеры (без учёта вложенных папок), а также
создание списка найденных файлов.
| Private Sub Example3_AppFileSearch()
iPath$ = "C:\Мои документы;D:\Примеры"
Application.ScreenUpdating = False
Workbooks.Add xlWBATWorksheet
With Application.FileSearch
.NewSearch
.LookIn = iPath$
.SearchSubFolders = False ' True
.FileName = "*.xls" '".xls" - Excel97
.FileType = msoFileTypeExcelWorkbooks
For iCount& = 1 To .Execute
Cells(iCount&, 1) = .FoundFiles(iCount&)
Next
End With
Application.ScreenUpdating = True
End Sub |
Комментарий : В данном примере, можно указать либо FileName,
либо FileType
Важно : Если при использовании
данных примеров у Вас возникли подозрения в некорректности полученных
результатов, например, .Execute возвращает 0 в то время, как в указаной
папке наличествуют искомые файлы, то рекомендую ознакомиться со
следующей статьей :
A VBA program in Office XP that uses the FileSearch object
does not return correct results on a Windows XP/2000/ME
Вариант IV.
Для перебора всех файлов и вложенных папок можно использовать
об'ект Shell
| Private Sub Example_ObjectShell() 'Win98/Me/2000
Dim iPath$, iCountFolders&, iCountFiles&
Dim iFolder As Object, iFolderItem As Object
iPath = "C:\Мои документы" '"C:\Мои документы\"
Set iFolder = _
CreateObject("Shell.Application").NameSpace(CVar(iPath))
If Not iFolder Is Nothing Then
For Each iFolderItem In iFolder.Items
If Not iFolderItem.IsFolder Then
iCountFiles = iCountFiles + 1
Else
iCountFolders = iCountFolders + 1
End If
'MsgBox iFolderItem.Path 'полное имя файла
'MsgBox iFolderItem.Name 'имя файла без расширения
Next
MsgBox "В папке объектов = " & iFolder.Items.Count
MsgBox "В папке из них папок = " & iCountFolders
MsgBox "В папке из них файлов = " & iCountFiles
Else
MsgBox "Папка отсутствует", vbCritical, iPath
End If
End Sub |
Особенности версии V4.71:
Последним символом в имени папки не обязательно должен
быть слэш \
Если Вы забудете указать папку, т.е. iPath$ = ""
то перебор файлов, скорее всего, будет осуществляться в
виртуальной папке Мой компьютер
В переборе будут участвовать не только файлы, но и папки
При переборе файлы/папки, имеющие атрибут Скрытый ,
игнорируются.
Нет возможности перебора только файлов нужного типа,
например, рабочих книг (обходное решение есть во втором примере)
Примечание :
Используя об'ект FolderItem можно получить как полное имя
файла, так и имя без расширения, кроме того, этот об'ект
позволяет получить некоторые свойства файла/папки, например,
размер файла, дату, тип, без применения соответствующих VB или
WinAPI функций
С помощью об'екта Shell можно создавать новые папки, а
также перемещать, копировать и переименовывать уже
существующие файлы/папки.
Private Sub Example2_ObjectShell() 'Win98/Me/2000
Dim iPath$, iCountFiles&
Dim iFolder As Object, iFolderItem As Object
iPath = Application.DefaultFilePath
Set iFolder = _
CreateObject("Shell.Application").NameSpace((iPath))
If Not iFolder Is Nothing Then
For Each iFolderItem In iFolder.Items
If Not iFolderItem.IsFolder Then
If LCase(Right(iFolderItem.Path, 4)) = _
".xls" Then iCountFiles = iCountFiles + 1
End If
Next
MsgBox "В папке файлов с расширением .xls = " & iCountFiles
Else
MsgBox "Папка отсутствует", vbCritical, iPath
End If
End Sub |
| Private Sub Example2v2_ObjectShell() 'Win98/Me/2000
Dim iPath, iCountFiles&, iFolderItem As Object
iPath = Application.Path 'вряд ли папка с Excel отсутствует
For Each iFolderItem In _
CreateObject("Shell.Application").NameSpace(iPath).Items
If Not iFolderItem.IsFolder Then
If LCase(iFolderItem.Path) _
Like "*.exe" Then iCountFiles = iCountFiles + 1
End If
Next
MsgBox "В папке файлов с расширением .exe = " & iCountFiles
End Sub |
Особенности версии V6.0: В этой версии появилась
возможность фильтрации, с помощью чего можно :
Перебрать только файлы, игнорируя папки (см. третий пример - 64)
Перебрать в т.ч. и скрытые файлы (см. третий пример - 128)
Перебрать или подсчитать только файлы с нужным именем и/или
расширением (см. третий пример)
Private Sub Example3_ObjectShell() 'WinXP
Dim iPath, iCountFiles&, iFolder As Object
Dim iFolderItems As Object, iFolderItem As Object
iPath = Application.DefaultFilePath
Set iFolder = _
CreateObject("Shell.Application").NameSpace(iPath)
If Not iFolder Is Nothing Then
Set iFolderItems = iFolder.Items
iFolderItems.Filter 64 + 128, "*.xls"
For Each iFolderItem In iFolderItems
'MsgBox iFolderItem.Path 'полное имя файла
'MsgBox iFolderItem.Name 'имя файла без расширения
Next
MsgBox "В папке файлов .xls = " & iFolderItems.Count
Else
MsgBox "Папка отсутствует", vbCritical, iPath
End If
End Sub |
Вариант V.
Для перебора всех файлов (на самом деле и папок) можно
использовать соответствующие WinAPI функции FindFirstFile ,
FindNextFile + FindClose
| Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260 '256+4
cAlternate As String * 14
End Type
Private Declare Function FindFirstFile _
Lib "kernel32.dll" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile _
Lib "kernel32.dll" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose _
Lib "kernel32.dll" ( _
ByVal hFindFile As Long) As Long
Private Sub Example_WinAPIFindFile()
Dim iPosition As Integer
Dim iFindFileData As WIN32_FIND_DATA
Dim ihFindFile As Long, iCount As Long
Dim iPath As String, iFileName As String
iPath = "C:\Мои документы\*.xls"
ihFindFile = FindFirstFile(iPath, iFindFileData)
If ihFindFile <> -1 Then
Do
'Microsoft Excel'
iFileName = Application.Clean(iFindFileData.cFileName)
'Microsoft Word, VB'
'iFileName = iFindFileData.cFileName
'iPosition = InStr(iFileName, vbNullChar)
'If iPosition > 0 Then _
'iFileName = Left(iFileName, iPosition - 1) 'Or Mid
iCount = iCount + 1
Loop Until FindNextFile(ihFindFile, iFindFileData) = 0
FindClose ihFindFile
MsgBox "В папке объектов = " & iCount
Else
MsgBox "Ни одного файла с указанным расширением, не найдено"
End If
End Sub |
Комментарий : Если существует вероятность того, что в папке
могут находиться вложенные подпапки, имена которых будут заканчиваться
.xls , то в таком случае желательно добавить соответствующую проверку.
Вариант VI.
Для перебора всех файлов можно также использовать об'ект
FileSystemObject
| Private Sub Example_ObjectFSO()
Dim iPath$, iFileSystemObj As Object
Dim iFiles As Object, iFile As Object
iPath = "C:\Мои документы" '"C:\Мои документы\"
Set iFileSystemObj = CreateObject("Scripting.FileSystemObject")
If iFileSystemObj.FolderExists(iPath) = True Then
Set iFiles = iFileSystemObj.GetFolder(iPath).Files
MsgBox "В папке файлов = " & iFiles.Count 'для примера
For Each iFile In iFiles
'MsgBox iFile.Name 'имя файла
'MsgBox iFile.Path 'полное имя файла
'MsgBox iFile.ShortName/iFile.ShortPath 'короткие имена
Next
Else
MsgBox "Папка отсутствует", vbCritical, iPath
End If
End Sub |
| Private Sub Example2_ObjectFSO()
Dim iPath$, iCount&, iFile As Object
iPath = "C:\Мои документы\" '"C:\Мои документы"
If Dir(iPath, vbDirectory) <> "" Then
With CreateObject("Scripting.FileSystemObject")
For Each iFile In .GetFolder(iPath).Files
iCount = iCount + 1
'MsgBox iFile.Name 'имя файла
'MsgBox iFile.Path 'полное имя файла
'MsgBox iFile.ShortName/iFile.ShortPath 'короткие имена
Next
MsgBox "В папке файлов = " & iCount
'Количество файлов в папке можно
'определить и без цикла (см. предыдущий пример)
End With
Else
MsgBox "Папка отсутствует", vbCritical, iPath
End If
End Sub |
Особенности :
Последним символом в имени папки не обязательно должен
быть слэш \
В переборе будут участвовать все файлы, в т.ч. с атрибутами
Скрытый и/или Только для чтения
При использовании FSO нельзя перебрать только файлы нужного
типа, например, рабочих книг (обходное решение есть в следующих
примерах), однако, есть возможность перебора только вложенных
папок
Примечание :
Используя свойства об'екта iFile можно получить различные
имена файлов (см. предыдущие примеры), кроме того, этот об'ект
позволяет получить некоторые свойства файла, например, размер файла,
дату, тип, без применения соответствующих VB или WinAPI функций
С помощью об'екта FSO можно создавать новые папки, перемещать,
копировать и переименовывать уже существующие файлы ( и папки )
и многое другое. Более подробно смотрите
здесь ...
Private Sub Example3_ObjectFSO()
Dim iFileSystemObj As Object, iFiles As Object
Dim iPath$, iCount&, iFile As Object
iPath = "C:\Мои документы" '"C:\Мои документы\"
Set iFileSystemObj = CreateObject("Scripting.FileSystemObject")
If iFileSystemObj.FolderExists(iPath) = True Then
Set iFiles = iFileSystemObj.GetFolder(iPath).Files
For Each iFile In iFiles
If LCase(iFileSystemObj.GetExtensionName(iFile)) = "xls" Then
iCount = iCount + 1
End If
Next
MsgBox "В папке .xls файлов = " & iCount
Else
MsgBox "Папка отсутствует", vbCritical, iPath
End If
End Sub |
| Private Sub Example4_ObjectFSO()
Dim iPath$, iCount&, iFile As Object
iPath = "C:\Мои документы\" '"C:\Мои документы"
If Dir(iPath, vbDirectory) <> "" Then
With CreateObject("Scripting.FileSystemObject")
For Each iFile In .GetFolder(iPath).Files
If UCase(.GetExtensionName( _
iFile.Name)) = "XLS" Then iCount = iCount + 1
Next
MsgBox "В папке .xls файлов = " & iCount
End With
Else
MsgBox "Папка отсутствует", vbCritical, iPath
End If
End Sub |
| Private Sub Example5_ObjectFSO()
Dim iPath$, iCount&, iFile As Object
iPath = Application.LibraryPath
With CreateObject("Scripting.FileSystemObject")
If .FolderExists(iPath) = True Then
For Each iFile In .GetFolder(iPath).Files
'If UCase(Right(iFile.Name, 4)) Like ".XL?" Then
If UCase(iFile.Name) Like "*.XL?" Then
iCount = iCount + 1
End If
Next
MsgBox "В папке искомых файлов = " & iCount
Else
MsgBox "Эта папка вряд ли отсутствует"
End If
End With
End Sub |
| Option Compare Text
Private Sub Example6_ObjectFSO()
Dim iPath$, iCount&, iFile As Object
iPath = Application.DefaultFilePath
With CreateObject("Scripting.FileSystemObject")
If .FolderExists(iPath) = True Then
For Each iFile In .GetFolder(iPath).Files
If iFile.Name Like "Список*.txt" Then iCount = iCount + 1
Next
MsgBox _
"Текстовых файлов, начинающихся со слова Список = " & iCount&
Else
MsgBox "Папка отсутствует", vbCritical, iPath
End If
End With
End Sub |
Вариант VII.
Если Вас устроит вывод информации, например, в текстовый файл, то
получить перечень всех файлов (включая вложеные) нужной папки, можно также
с помощью команды MS-DOS - Dir
|
Shell "Cmd.exe /U /C Dir C:\ > C:\FilesList.txt /A /O:G /S /B", vbHide |
У данной команды довольно много параметров, которые позволяют не просто
получить список файлов(папок), но и отсортировать их, задать нужное расширение
или атрибуты, что позволит, к примеру, создать список, содержащий только папки
или только скрытые файлы, или же *.XLS файлы, и т.п. Более подробную информацию
можно получить
здесь (англ.) или здесь
(русск.), только не забывайте, что имя папки с пробелом, необходимо заключать в
скобки "" , т.е.
| iPath = "C:\Мои документы\"
Shell "Cmd.exe /U /C Dir """ & _
iPath & """ > C:\FoldersList.txt /A:D /S /B", vbHide |
Автор : Климов Павел Юрьевич
| | | | | |
|
© 2004-2016 Климов П.Ю. Все права защищены. |
WebDesign & Error's
Klimoff
|