MyTetra Share
Делитесь знаниями!
Класс для создания и распаковки архивов ZIP
Время создания: 31.07.2019 23:23
Текстовые метки: vba_zip
Раздел: !Закладки - VBA - VBA ZIP
Запись: xintrea/mytetra_db_adgaver_new/master/base/1514655925khoytzomjs/text.html на raw.githubusercontent.com

Класс для создания и распаковки архивов 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. Работа с ключами и параметрами.

 
MyTetra Share v.0.59
Яндекс индекс цитирования