Работа с zip архивами

Public Function UnzipAll( _
                ByRef sFileName As String) As CZIPStreams
    Dim hr          As Long
    Dim cShExt      As IShellExtInit
    Dim cPFolder    As IPersistFolder2
    Dim cStreams    As CZIPStreams
    Dim lPidl       As Long
    Dim sFullPath   As String
    
    hr = CoCreateInstance(CLSID_CompressedFolder, Nothing, CLSCTX_INPROC_SERVER, IID_IShellExtInit, cShExt)
    If hr < 0 Then
        Err.Raise hr, , "CoCreateInstance failed"
    End If
    
    Set cPFolder = cShExt
    
    sFullPath = GetFullPath(sFileName)
    
    hr = SHParseDisplayName(StrPtr(sFullPath), Nothing, lPidl, 0, 0)
    If hr < 0 Then
        Err.Raise hr, , "SHParseDisplayName failed"
    End If
    
    cPFolder.Initialize lPidl
    
    ILFree lPidl
    
    Set cStreams = New CZIPStreams
    
    Set cStreams.Parent = Me
    
    AddToZipStreams cStreams, cPFolder, vbNullString
    
    Set m_cStreams = cStreams
    Set UnzipAll = cStreams
    
End Function
 
Private Sub AddToZipStreams( _
            ByVal cStreams As CZIPStreams, _
            ByVal cStg As IStorage, _
            ByRef sPath As String)
    Dim hr          As Long
    Dim cStm        As IStream
    Dim cEnum       As IEnumSTATSTG
    Dim cZIPStm     As CZIPStream
    Dim bData()     As Byte
    Dim bEmptyStm() As Byte
    Dim tStat       As STATSTG
    Dim tSize       As LARGE_INTEGER
    Dim sName       As String
    
    Set cEnum = cStg.EnumElements
    
    cEnum.Reset
    
    Do While cEnum.Next(1, tStat) = S_OK
        
        sName = SysAllocString(ByVal tStat.pwcsName)
        
        CoTaskMemFree tStat.pwcsName
        
        Select Case tStat.Type
        Case STGTY_STREAM
            
            Set cStm = cStg.OpenStream(sName, 0, STGM_READ Or STGM_SHARE_EXCLUSIVE)
            
            GetMem8 tStat.cbSize, tSize
            
            If tSize.hipart <> 0 Or tSize.lowpart < 0 Or tSize.lowpart > 300000000 Then
                Err.Raise 7
            End If
 
            If tSize.lowpart Then
                
                ReDim bData(tSize.lowpart - 1)
                
                cStm.Read bData(0), tSize.lowpart
                    
                Set cZIPStm = cStreams.Add(sPath & sName, bData)
            
            Else
                Set cZIPStm = cStreams.Add(sPath & sName, bEmptyStm)
            End If
            
            Set cStm = Nothing
            
        Case STGTY_STORAGE
            AddToZipStreams cStreams, cStg.OpenStorage(sName, 0, STGM_READ Or STGM_SHARE_EXCLUSIVE), sPath & sName & "\"
        End Select
        
    Loop
    
End Sub

Public Sub Zip( _
           ByRef sFileName As String, _
           ByVal cStreams As CZIPStreams)
    Dim sFiles()    As String
    Dim lPidl()     As Long
    Dim lIndex      As Long
    Dim sFilesList  As String
    Dim tFO         As SHFILEOPSTRUCT
    Dim hr          As Long
    Dim cDropTarget As IDropTarget
    Dim cDataObj    As IDataObject
    Dim cPFile      As IPersistFile
    Dim cSFolder    As IShellFolder
    Dim cInitItem   As IInitializeWithItem
    Dim cShellItem  As IShellItem
    Dim hwnd        As Long
    Dim lNotifyID   As Long
    Dim tEntry      As SHChangeNotifyEntry
    Dim lRet        As Long
    Dim tMSG        As MSG
    Dim sFullPath   As String
    Dim hEvent      As Long
    Dim lError      As Long
    
    sFullPath = GetFullPath(sFileName)
    
    CreateEmptyArchive sFullPath
    
    If cStreams.Count = 0 Then
        Exit Sub
    End If
    
    On Error GoTo error_handler
    
    tEntry.pidl = ILCreateFromPathW(StrPtr(sFullPath))
    
    hwnd = CreateZipNotifyWindow
    
    lNotifyID = SHChangeNotifyRegister(hwnd, SHCNRF_ShellLevel Or SHCNRF_NewDelivery, _
                                       SHCNE_UPDATEITEM, WM_ZIP_COMPLETED, 1, tEntry)
    
    If lNotifyID = 0 Then
        Err.Raise 7, , "SHChangeNotifyRegister failed"
    End If
    
    hr = CoCreateInstance(CLSID_CompressedFolder, Nothing, CLSCTX_INPROC_SERVER, IID_IShellFolder, cSFolder)
    
    If hr < 0 Then
        Err.Raise hr, , "CoCreateInstance failed"
    End If
    
    cSFolder.CreateViewObject hwnd, IID_IDropTarget, cDropTarget
    
    On Error Resume Next
    
    Set cPFile = cDropTarget
    
    lError = Err.Number
    
    On Error GoTo -1
    On Error GoTo error_handler
    
    If lError = 0 Then
        cPFile.Load sFullPath, STGM_READWRITE Or STGM_SHARE_EXCLUSIVE
    Else
        
        Set cInitItem = cDropTarget
        
        hr = SHCreateItemFromParsingName(StrPtr(sFullPath), Nothing, IID_IShellItem, cShellItem)
        
        If hr < 0 Then
            Err.Raise hr, , "SHCreateItemFromParsingName failed"
        End If
        
        cInitItem.Initialize cShellItem, STGM_READWRITE
        
    End If
 
    sFiles = CreateTemporaryFiles(cStreams)
    
    If (Not Not sFiles) = 0 Then
        Exit Sub
    End If
    
    ReDim lPidl(UBound(sFiles))
    
    For lIndex = 0 To UBound(sFiles)
        lPidl(lIndex) = ILCreateFromPathW(StrPtr(sFiles(lIndex)))
    Next
    
    hr = SHCreateFileDataObject(VarPtr(0&), UBound(lPidl) + 1, lPidl(0), ByVal 0&, cDataObj)
    
    If hr < 0 Then
        Err.Raise hr, , "SHCreateFileDataObject failed"
    End If
    
    cDropTarget.DragEnter cDataObj, MK_LBUTTON, 0&, 0&, DROPEFFECT_COPY
    cDropTarget.Drop cDataObj, MK_LBUTTON, 0&, 0&, DROPEFFECT_COPY
    
    hEvent = GetWindowLong(hwnd, 0)
    
    Do
        
        lRet = MsgWaitForMultipleObjects(1, hEvent, 0, -1, QS_ALLINPUT Or QS_ALLPOSTMESSAGE)
        
        If lRet = 0 Then
            Exit Do
        ElseIf lRet = 1 Then
        
            PeekMessage tMSG, 0, 0, 0, PM_REMOVE
            TranslateMessage tMSG
            DispatchMessage tMSG
            
        Else
            Exit Do
        End If
 
    Loop
    
error_handler:
    
    If Not Not lPidl Then
        For lIndex = 0 To UBound(lPidl)
            ILFree lPidl(lIndex)
        Next
    End If
    
    If Not Not sFiles Then
        
        sFilesList = Left$(sFiles(0), InStrRev(sFiles(0), "\") - 1) & vbNullChar
        
        With tFO
            .pFrom = StrPtr(sFilesList)
            .wFunc = FO_DELETE
            .fFlags = FOF_NOCONFIRMATION Or FOF_NOCONFIRMMKDIR Or FOF_NOERRORUI Or FOF_SILENT
        End With
        
        SHFileOperation tFO
 
    End If
    
    If lNotifyID Then
        SHChangeNotifyDeregister lNotifyID
    End If
    
    If hwnd Then
        If GetClassLong(hwnd, 0) <= 1 Then
            DestroyWindow hwnd
            UnregisterClass StrPtr(ZIP_NOTIFY_WND_CLASS), App.hInstance
        Else
            SetClassLong hwnd, 0, GetClassLong(hwnd, 0) - 1
            DestroyWindow hwnd
        End If
    End If
    
    If Err.Number Then
        Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    End If
        
End Sub