|
Функция предназначена для получения файлов, извлечённых из архива ZIP.
Разархивирование выполняется средствами Windows, файлы извлекаются в специально созданную папку в каталоге для временных файлов (C:\WINDOWS\Temp\)
При запуске макроса папка UNZIPPED FILES сначала удаляется, а потом создаётся заново.
(таким образом, выполняется удаление файлов, которые могли оказаться в папке при предыдущем запуске макроса)
Функция возвращает коллекцию, содержащую полные пути к извлечённым файлам.
См. также функцию UnZip_File, предназначенную для разархивирования файлов
в заданную папку, с возможностью удаления исходного файла-архива.
Пример использования функции FilesFromZip:
Sub ПримерИспользования()
On Error Resume Next
file$ = "D:\Проекты\Прайсы\Архив.zip" ' путь к архиву, из которого будем извлекать файлы
Dim coll As Collection
Set coll = FilesFromZip(file)
Debug.Print "Извлечено файлов: " & coll.Count ' выводи количество файлов
For Each filename In coll ' выводим пути к извлечённым из архива ZIP файлам
Debug.Print filename
Next
End Sub
Результат:
Извлечено файлов: 7
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс лист BMW.xls
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс лист LAMBO.xls
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс лист Porche.xls
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс лист ROVER.xls
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс лист VAG.xls
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс-лист Ford.xls
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс-лист Мерседес.xls
Код функции FilesFromZip:
Для работы функции, необходимо дополнительно скопировать
в стандартный модуль код функции FilenamesCollection
Function FilesFromZip(ByVal FileNameZip) As Collection
' Функция осуществляет распаковку архива с именем FileNameZip во временную папку
' (предварительно удаляя папку с таким именем, если она существует)
' Возвращает коллекцию, содержащую пути ко всем извлечённым из архива файлам)
On Error Resume Next: Err.Clear: Set FilesFromZip = New Collection
folder = Environ("tmp") & "\UNZIPPED FILES\"
Shell "cmd /c rd /S/Q """ & folder & """" ' удаляем папку
DoEvents: DoEvents: DoEvents: DoEvents:
MkDir folder ' и создаём эту папку заново
DoEvents: DoEvents: DoEvents: DoEvents: Err.Clear
If Len(Dir(folder, vbDirectory)) = 0 Then Exit Function ' не удалось создать папку
If Len(Dir(FileNameZip)) = 0 Then MsgBox "Файл """ & FileNameZip & """ не найден!", _
vbCritical, "Ошибка в функции FilesFromZip": Exit Function
Set oApp = CreateObject("Shell.Application")
For Each it In oApp.Namespace(FileNameZip).Items: DoEvents: DoEvents: Next
oApp.Namespace(folder).CopyHere oApp.Namespace(FileNameZip).Items 'распаковываем файлы
Set FilesFromZip = FilenamesCollection(folder, "*")
End Function
Другая версия функции, - работает более стабильно,
возвращает путь к файлу XLS из архива:
Function FileFromZip(ByVal FileNameZip) As String
' Функция осуществляет распаковку архива с именем FileNameZip во временную папку
' возвращает путь к разархивированному файлу Excel
On Error Resume Next: Err.Clear
folder = Environ("tmp") & "\UNZIP_" & Timer & "\"
MkDir folder ' и создаём эту папку заново
If Len(Dir(folder, vbDirectory)) = 0 Then Exit Function ' не удалось создать папку
If Len(Dir(FileNameZip)) = 0 Then MsgBox "Файл """ & FileNameZip & """ не найден!", _
vbCritical, "Ошибка в функции FilesFromZip": Exit Function
Set oApp = CreateObject("Shell.Application")
For Each it In oApp.Namespace(FileNameZip).Items: DoEvents: DoEvents: Next
oApp.Namespace(folder).CopyHere oApp.Namespace(FileNameZip).Items 'распаковываем файлы
filename$ = folder & Dir(folder & "*.xls*", vbNormal)
If Dir(filename$, vbNormal) Then FileFromZip = filename$
End Function
|
