Класс для создания и распаковки архивов ZIP.
- позволяет обходить ошибку при добавлении пустых папок*
- позволяет добавлять файлы с атрибутом "скрытый"
- правильно рассчитывает задержку при распаковке в папку, где уже есть другие файлы
* за исключением уникальных случаев, когда в корне папки для упаковки попадутся:
объект (файл или папка) со знаком ; и пустая папка с таким же именем, где на месте ; стоит любой другой знак.
Код (vb.net):
Option Explicit
' ========= Пример архивирования папки ========
Dim Zip, ArcPath, FolderPath
' Где создаем архив
ArcPath = "h:\_VBS, WSH\Архивация\My_Class\test.zip"
' Какую папку архивируем
FolderPath = "h:\_VBS, WSH\Архивация\My_Class\ToArc"
Set Zip = New ZipClass
if (Zip.CreateArchive (ArcPath)) then ' старый архив затирается
Zip.CopyFolderToArchive FolderPath
end if
msgbox "Папка " & FolderPath & " заархивирована."
' ========= Пример добавления файла в уже созданный архив ========
Dim FilePath
' Какой файл архивировать
FilePath = "h:\_VBS, WSH\Архивация\My_Class\ZipClass.xls"
Zip.CopyFileToArchive FilePath
msgbox "Файл " & FilePath & " добавлен к архиву " & ArcPath
' ================== Распаковка архива ===================
Dim UnpackPath
' Путь, куда распаковуем
UnpackPath = "h:\_VBS, WSH\Архивация\My_Class\Unpack"
Zip.UnpackArchive ArcPath, UnpackPath
msgbox "Архив распакован в папку: " & UnpackPath
' --------------------------------------------------------------------------------------
' Класс создания архивов ZIP. Maded by Dragokas
'
' - позволяет обходить ошибку при добавлении пустых папок
' - позволяет добавлять файлы с атрибутом "скрытый"
' - правильно рассчитывает задержку при распаковке в папку, где уже есть другие файлы
' --------------------------------------------------------------------------------------
Class ZipClass
Private oShApp, oFSO, oArchive, ArcItemsNewCount, oFolderItems, oFolderItem, oArchiveItems, oTarget, oTargetItems, ZipHeader, isEmptyFolder, SHCONTF_FILES_AND_FOLDERS
Private Sub Class_Initialize() 'Инициализация объектов
'FolderItems3.Filter method ' http://msdn.microsoft.com/en-us/library/windows/desktop/bb787787(v=vs.85).aspx
Const SHCONTF_FOLDERS = &H20
Const SHCONTF_NONFOLDERS = &H40
Const SHCONTF_INCLUDEHIDDEN = &H80
Const SHCONTF_INCLUDESUPERHIDDEN = &H10000 ' Windows 7 and Later
SHCONTF_FILES_AND_FOLDERS = SHCONTF_FOLDERS Or SHCONTF_NONFOLDERS Or SHCONTF_INCLUDEHIDDEN Or SHCONTF_INCLUDESUPERHIDDEN
Set oShApp = CreateObject("Shell.Application")
set oFSO = CreateObject("Scripting.FileSystemObject")
End Sub
Function UnpackArchive(SourceArchive, DestPath) 'Распаковка архива
Set oArchiveItems = oShApp.NameSpace(SourceArchive).Items
on error resume next
if not oFSO.FolderExists(DestPath) then oFSO.CreateFolder(DestPath)
if Err.Number <> 0 then WScript.Echo("Не хватает прав для создания временной папки распаковки!"): UnpackArchive = false: Exit Function
on error goto 0
Set oTarget = oShApp.NameSpace(DestPath)
set oTargetItems = oTarget.Items
Dim oSCR: set oSCR = CreateObject("Scripting.Dictionary"): oSCR.CompareMode = 1
for each oFolderItem in oTargetItems: oSCR.Add oFolderItem.Name, "": Next ' подсчет кол-ва уникальных файлов
for each oFolderItem in oArchiveItems
if not oSCR.Exists(oFolderItem.Name) then oSCR.Add oFolderItem.Name, ""
Next
'CopyHere option ENUM: http://msdn.microsoft.com/en-us/library/windows/desktop/bb787866(v=vs.85).aspx
oTarget.CopyHere oArchiveItems, 4+16 '(4 - no ProgressBar, 16 - Yes to all, 1024 - suppress all errors)
Do: Wscript.Sleep 200: oTargetItems.Filter SHCONTF_FILES_AND_FOLDERS, "*": Loop Until oTargetItems.Count => oSCR.Count
UnpackArchive = true: set oArchiveItems = Nothing: set oTarget = Nothing
End Function
Function CreateArchive(ZipArchivePath) 'Подготовка ZIP-архива
If lcase(oFSO.GetExtensionName(ZipArchivePath)) <> "zip" Then WScript.Echo("Указано неверное расширение для архива!"): Exit Function
ZipHeader = "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
on error resume next
with oFSO.OpenTextFile(ZipArchivePath, 2, True)
if Err.Number <> 0 then WScript.Echo("Не хватает прав для создания архива!"): CreateArchive = False: Exit function
.Write ZipHeader: .Close: end with
on error goto 0
Do: WScript.Sleep(100): Loop until oFSO.FileExists(ZipArchivePath): WScript.Sleep(200) 'выжидаем время, пока ZIP-архив не будет создан
Set oArchive = oShApp.NameSpace(ZipArchivePath): if Not (oArchive is Nothing) Then CreateArchive = True
End Function
Function CopyFileToArchive(srcFilePath) 'Копируем файл в ZIP-архив
ArcItemsNewCount = oArchive.Items.Count + 1
Dim srcFileName: srcFileName = oFSO.GetBaseName(srcFilePath)
for each oFolderItem in oArchive.Items ' Проверяем, существует ли уже такой файл в архиве
if strcomp(oFolderItem.name, srcFileName) = 0 then ArcItemsNewCount = oArchive.Items.Count - 1: exit for
next
oArchive.CopyHere srcFilePath ', 4 + 16 + 1024 'these options works only with unzipped folder
Do: Wscript.Sleep 200: Loop Until oArchive.Items.Count => ArcItemsNewCount 'Выжидаем пока кол-во объектов в ZIP-архиве станет >= копируемым в него
End Function
Function CopyFolderToArchive(srcFolderPath) 'Копируем содержимое папки в ZIP-архив
Dim sFilter: set oFolderItems = oShApp.NameSpace(srcFolderPath).Items
oFolderItems.Filter SHCONTF_FILES_AND_FOLDERS, "*" 'включаем в архив скрытые файлы
For each oFolderItem in oFolderItems ' поиск пустых папок
isEmptyFolder = false
if oFolderItem.IsFolder then if oFolderItem.GetFolder.Items.Count = 0 then isEmptyFolder = true
if not isEmptyFolder then sFilter = sFilter & ";" & replace(oFolderItem.Name, ";", "?") ' белый список объектов для фильтра
Next
oFolderItems.Filter SHCONTF_FILES_AND_FOLDERS, mid(sFilter, 1)
ArcItemsNewCount = oArchive.Items.Count + oFolderItems.Count
oArchive.CopyHere oFolderItems
Do: Wscript.Sleep 200: Loop Until oArchive.Items.Count => ArcItemsNewCount 'Выжидаем пока кол-во объектов в ZIP-архиве станет >= копируемым в него
End Function
End Class
Реестр Windows. Работа с ключами и параметрами.
