D:\YandexDisk\АРХИВАЦИЯ - ИЗВЛЕЧЕНИЕ ИЗ АРХИВА ЧЕРЕЗ VBA

Sheel

http://msoffice-nm.ru/faq/macros/shell.htm#faq422

http://msoffice-nm.ru/faq/macros/shell.htm#faq410

http://forum.script-coding.com/viewtopic.php?id=10217

'http://www.cyberforum.ru/visual-basic/thread987773.html

'Запись в архив

'***************************************************************

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub CopyFileToArchiv(ZipName As String, FileName As String)

' ZipName - полный путь к архиву

' FileName - полный путь к архивируемому файлу

Dim ShellApp As Object

Dim DestFolder As Object

Set ShellApp = CreateObject("Shell.Application")

Set DestFolder = ShellApp.NameSpace((ZipName))

' копируемый выбранный файл в zip папку

DestFolder.CopyHere (FileName)

' ожидаем окончание сжатия файла

Do Until DestFolder.Items.Count = 1

Sleep 100

Loop

Set ShellApp = Nothing

End Sub

'*

'Так можно узнать имена фойлов в ZIP-архиве !]

Public Function fnNameArchiveFile(ZipName As String, Optional i As Integer = 0, _

Optional fext As Boolean = True) As String

' ZipName - имя архива

' i - номер файла в архиве (начало с 0), по умолчанию - 0

' fext - включать расширение в имя файла, по умолчанию - true

Dim objShellApp As Object

Dim objFolder As Object

Set objShellApp = CreateObject("Shell.Application")

Set objFolder = objShellApp.NameSpace((ZipName))

If fext Then

fnNameArchiveFile = objFolder.Items().Item((i)).Path

Else

fnNameArchiveFile = objFolder.Items().Item((i)).Name

End If

End Function

'И з в л е ч е н и е ! (всё вопрос я снимаю

Public Sub UnZipFile(ZipName As String, DestPath As String)

' ZipName - полный путь к архиву

' DestPath - полный путь к папке для распаковки архива

Dim ShellApp As Object

Set ShellApp = CreateObject("Shell.Application")

'Copy the files in the newly created folder

ShellApp.NameSpace((DestPath)).CopyHere ShellApp.NameSpace((ZipName)).Items

Set ShellApp = Nothing

End Sub