Архиваторы - Модуль работы с ZIP файлами средствами Windows

По материалам: https://accessexperts.com/blog/2012/02/06/zipandunzipfrommicrosoftvba/

'--------------------------------------------------------------------

' Module : modZip

' Author : Ben Clothier

' : http://accessexperts.com/blog/2012/02/06/zipandunzipfrommicrosoftvba/

' Date : 06.02.2012

' Purpose : Модуль работы с ZIP файлами средствами Windows

'--------------------------------------------------------------------

Option Compare Database

Option Explicit

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

'http://accessexperts.com/blog/2012/02/06/zipandunzipfrommicrosoftvba/

Public Sub Zip(ZipFile As String, InputFile As String)

On Error GoTo ErrHandler

Dim FSO As Object 'Scripting.FileSystemObject

Dim oApp As Object 'Shell32.Shell

Dim oFld As Object 'Shell32.Folder

Dim oShl As Object 'WScript.Shell

Dim i As Long

Dim l As Long

Set FSO = CreateObject("Scripting.FileSystemObject")

If Not FSO.FileExists(ZipFile) Then

'Create empty ZIP file

FSO.CreateTextFile(ZipFile, True).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)

End If

Set oApp = CreateObject("Shell.Application")

Set oFld = oApp.NameSpace(CVar(ZipFile))

i = oFld.Items.Count

oFld.CopyHere (InputFile)

Set oShl = CreateObject("WScript.Shell")

'Search for a Compressing dialog

Do While oShl.AppActivate("Compressing...") = False

If oFld.Items.Count > i Then

'There's a file in the zip file now, but

'compressing may not be done just yet

Exit Do

End If

If l > 30 Then

'3 seconds has elapsed and no Compressing dialog

'The zip may have completed too quickly so exiting

Exit Do

End If

DoEvents

Sleep 100

l = l + 1

Loop

' Wait for compression to complete before exiting

Do While oShl.AppActivate("Compressing...") = True

DoEvents

Sleep 100

Loop

ExitProc:

On Error Resume Next

Set FSO = Nothing

Set oFld = Nothing

Set oApp = Nothing

Set oShl = Nothing

Exit Sub

ErrHandler:

Select Case Err.Number

Case Else

MsgBox "Error " & Err.Number & _

": " & Err.Description, _

vbCritical, "Unexpected error"

End Select

Resume ExitProc

Resume

End Sub

Public Sub UnZip(ZipFile As String, Optional TargetFolderPath As String = vbNullString, Optional OverwriteFile As Boolean = False)

On Error GoTo ErrHandler

Dim oApp As Object

Dim FSO As Object

Dim fil As Object

Dim DefPath As String

Dim strDate As String

Set FSO = CreateObject("Scripting.FileSystemObject")

If Len(TargetFolderPath) = 0 Then

DefPath = CurrentProject.Path & ""

Else

If FSO.folderexists(TargetFolderPath) Then

DefPath = TargetFolderPath & ""

Else

Err.Raise 53, , "Folder not found"

End If

End If

If FSO.FileExists(ZipFile) = False Then

MsgBox "System could not find " & ZipFile _

& " upgrade cancelled.", _

vbInformation, "Error Unziping File"

Exit Sub

Else

'Extract the files into the newly created folder

Set oApp = CreateObject("Shell.Application")

With oApp.NameSpace(ZipFile & "")

If OverwriteFile Then

For Each fil In .Items

If FSO.FileExists(DefPath & fil.Name) Then

Kill DefPath & fil.Name

End If

Next

End If

oApp.NameSpace(CVar(DefPath)).CopyHere .Items

End With

On Error Resume Next

Kill Environ("Temp") & "Temporary Directory*"

'Kill zip file

Kill ZipFile

End If

ExitProc:

On Error Resume Next

Set oApp = Nothing

Exit Sub

ErrHandler:

Select Case Err.Number

Case Else

MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"

End Select

Resume ExitProc

Resume

End Sub