🚀 Создание и распаковка ZIP-архива с помощью VBA Excel

С помощью VBA можно легко создавать ZIP-архивы и распаковывать их без сторонних программ.

📦 Создание ZIP-архива:

Sub CreateZipArchive()
    Dim oShell As New Shell32.Shell
    Dim oSourceFolder As Shell32.Folder
    Dim oZipFolder As Shell32.Folder
    Dim sourceFolder As String
    Dim zipFile As String
    Dim startTime As Double
    Dim timeoutSeconds As Double
    
    ' Укажите свои пути
    sourceFolder = "C:\Test\Лагенария\"
    zipFile = "C:\Test\Лагенария.zip"
    
    ' Проверка исходной папки
    Set oSourceFolder = oShell.Namespace(sourceFolder)
    If oSourceFolder Is Nothing Then
        MsgBox "Исходная папка '" & sourceFolder & "' не найдена или недоступна!", vbExclamation
        Exit Sub
    End If
    
    ' Создаем архив
    On Error Resume Next
    If Dir(zipFile) = "" Then
        CreateObject("Scripting.FileSystemObject").CreateTextFile(zipFile).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
        If Err.Number <> 0 Then
            MsgBox "Ошибка при создании ZIP-файла: " & Err.Description, vbCritical
            Exit Sub
        End If
    End If
    On Error GoTo 0
    
    ' Проверка ZIP-файла
    Set oZipFolder = oShell.Namespace(zipFile)
    If oZipFolder Is Nothing Then
        MsgBox "Не удалось создать или открыть ZIP-архив!", vbCritical
        Exit Sub
    End If
    
    ' Добавляем файлы
    oZipFolder.CopyHere oSourceFolder.Items
    
    ' Ждем завершения с тайм-аутом
    startTime = Timer
    timeoutSeconds = 30
    Do Until oZipFolder.Items.Count = oSourceFolder.Items.Count
        Application.Wait (Now + TimeValue("0:00:01"))
        If Timer - startTime > timeoutSeconds Then
            MsgBox "Тайм-аут: процесс архивации не завершился за " & timeoutSeconds & " секунд.", vbExclamation
            Exit Sub
        End If
    Loop
    
    MsgBox "ZIP-архив успешно создан! (" & oZipFolder.Items.Count & " элементов)", vbInformation
End Sub

🛠 Настройка:
1️⃣ Откройте VBA Editor (Alt + F11).
2️⃣ Перейдите в Tools → References.
3️⃣ Подключите библиотеку Microsoft Shell Controls And Automation.
4️⃣ Замените пути на свои и протестируйте код.

💡 Примечания
🔹 Код может быть значительно короче, но данный код учитывает больше возможных ошибок.
🔹 Для объектов Shell используется ранняя привязка (для этого потребовалось подключить библиотеку Microsoft Shell Controls And Automation) — мне не удалось заставить его работать с поздней привязкой на своем компьютере.

#VBA #ExcelVBA #ZIP #Архив #Создание

📂 Распаковка ZIP-архива:

Sub ExtractZipArchive()
    Dim oShell As Shell32.Shell
    Dim oZipFolder As Shell32.Folder
    Dim oExtractFolder As Shell32.Folder
    Dim zipFile As String
    Dim extractPath As String
    Dim startTime As Double
    Dim timeoutSeconds As Double
    
    ' Указываем пути
    zipFile = "C:\Test\Лагенария.zip"
    extractPath = "C:\Test\ЛагенарияКопия\"
    
    ' Инициализация Shell
    Set oShell = New Shell32.Shell
    
    ' Проверка существования архива
    If Dir(zipFile) = "" Then
        MsgBox "Архив '" & zipFile & "' не найден!", vbExclamation
        Exit Sub
    End If
    
    ' Проверка существования папки для распаковки, создание, если не существует
    On Error Resume Next
    If Dir(extractPath, vbDirectory) = "" Then
        MkDir extractPath
        If Err.Number <> 0 Then
            MsgBox "Не удалось создать папку для распаковки: " & Err.Description, vbCritical
            Exit Sub
        End If
    End If
    On Error GoTo 0
    
    ' Устанавливаем объекты
    Set oZipFolder = oShell.Namespace(zipFile)
    If oZipFolder Is Nothing Then
        MsgBox "Не удалось открыть ZIP-архив!", vbCritical
        Exit Sub
    End If
    
    Set oExtractFolder = oShell.Namespace(extractPath)
    If oExtractFolder Is Nothing Then
        MsgBox "Не удалось открыть папку для распаковки!", vbCritical
        Exit Sub
    End If
    
    ' Извлекаем содержимое
    oExtractFolder.CopyHere oZipFolder.Items
    
    ' Ждем завершения с тайм-аутом
    startTime = Timer
    timeoutSeconds = 30
    Do Until oExtractFolder.Items.Count = oZipFolder.Items.Count
        Application.Wait (Now + TimeValue("0:00:01"))
        If Timer - startTime > timeoutSeconds Then
            MsgBox "Тайм-аут: процесс распаковки не завершился за " & timeoutSeconds & " секунд.", vbExclamation
            Exit Sub
        End If
    Loop
    
    MsgBox "Архив успешно распакован! (" & oExtractFolder.Items.Count & " элементов)", vbInformation
End Sub

#VBA #ExcelVBA #ZIP #Архив #Распаковка