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

ret = CreateDeltaB(SetFlags:=DELTA_FLAG_IGNORE_FILE_SIZE_LIMIT, Trg_lpcStart:=bInp(0), Trg_uSize:=UBound(bInp) + 1, TrgOpt_Editable:=1, lpDelta:=DO_Res)

Option Explicit
'////////////////////////////////////////////////////////////////////////////////////
'// Модуль для упаковки и распаковки буфера с помощью технологии Delta Compression //
'// Copyright (c) 05.11.2024 by HackerVlad & testuser2                             //
'// E-mail: vladislavpeshkov@yandex.ru                                             //
'// Обсуждение темы: https://www.cyberforum.ru/visual-basic/thread3183774.html     //
'// Версия: 1.0                                                                    //
'////////////////////////////////////////////////////////////////////////////////////
 
Private Const DELTA_FILE_TYPE_RAW@ = 1 / 10000
Private Const DELTA_FLAG_IGNORE_FILE_SIZE_LIMIT@ = 131072 / 10000 ' &H20000 (0x00020000)
 
Private Declare Function CreateDeltaB Lib "msdelta" (Optional ByVal FileTypeSet As Currency = DELTA_FILE_TYPE_RAW, Optional ByVal SetFlags As Currency, Optional ByVal ResetFlags As Currency, Optional ByVal Src_lpcStart As LongPtr, Optional ByVal Src_uSize As LongPtr, Optional ByVal Src_Editable As Long, Optional ByRef Trg_lpcStart As Any, Optional ByVal Trg_uSize As LongPtr, Optional ByVal Trg_Editable As Long, Optional ByVal SrcOpt_lpcStart As LongPtr, Optional ByVal SrcOpt_uSize As LongPtr, Optional ByVal SrcOpt_Editable As Long, Optional ByVal TrgOpt_lpcStart As LongPtr, Optional ByVal TrgOpt_uSize As LongPtr, Optional ByVal TrgOpt_Editable As Long, Optional ByVal GlbOpt_lpcStart As LongPtr, Optional ByVal GlbOpt_uSize As LongPtr, Optional ByVal GlbOpt_Editable As Long, Optional ByVal lpTargetFileTime As LongPtr, Optional ByVal HashAlgId As Long, Optional ByRef lpDelta As Any) As Long
Private Declare Function ApplyDeltaB Lib "msdelta" (ByVal ApplyFlags As Currency, ByVal Src_lpcStart As LongPtr, ByVal Src_uSize As LongPtr, ByVal Src_Editable As Long, ByRef Dlt_lpcStart As Any, ByVal Dlt_uSize As LongPtr, ByVal Dlt_Editable As Long, ByRef lpTarget As DELTA_OUTPUT) As Long
Private Declare Function DeltaFree Lib "msdelta" (ByVal lpMemory As LongPtr) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
'## Раскомментировать в VB6 ##
Private Enum LongPtr
    [_]
End Enum
'#############################
 
Private Type DELTA_OUTPUT
    lpStart As LongPtr
    uSize As LongPtr
End Type
 
' Упаковать (сжать) данные байтового массива
Public Function CompressDeltaB(byteArray() As Byte) As Boolean
    On Error GoTo Quit
    
    Dim DO_Res As DELTA_OUTPUT
    Dim ret As Long
    
    ret = CreateDeltaB(SetFlags:=DELTA_FLAG_IGNORE_FILE_SIZE_LIMIT, Trg_lpcStart:=byteArray(0), Trg_uSize:=UBound(byteArray) + 1, lpDelta:=DO_Res)
    
    If ret Then
        With DO_Res
            ReDim byteArray(.uSize - 1)
            CopyMemory byteArray(0), ByVal .lpStart, .uSize
            DeltaFree (.lpStart)
        End With
        
        CompressDeltaB = True
    End If
Quit:
End Function
 
' Распаковать (извлечь) данные байтового массива
Public Function DeCompressDeltaB(byteArray() As Byte) As Boolean
    On Error GoTo Quit
    
    Dim DO_Res As DELTA_OUTPUT
    Dim ret As Long
    
    ret = ApplyDeltaB(0, 0, 0, 0, byteArray(0), UBound(byteArray) + 1, 0, DO_Res)
    
    If ret Then
        With DO_Res
            If .lpStart Then
                ReDim byteArray(.uSize - 1)
                CopyMemory byteArray(0), ByVal .lpStart, .uSize
                DeltaFree (.lpStart)
            End If
        End With
        
        DeCompressDeltaB = True
    End If
Quit:
End Function

Option Explicit
Private Declare Function RtlComputeCrc32 Lib "ntdll.dll" (ByVal dwInitial As Long, ByVal pData As Long, ByVal iLen As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetTickCount Lib "kernel32" () As Long
 
Private Function Crc32Api(tBuff() As Byte) As Long
    Crc32Api = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
End Function
 
Private Function CreatingDLL() As Boolean
    Dim FileNo As Integer
    Dim buf() As Byte
    Dim dll() As Byte
    
    buf = LoadResData(101, "DELTA") ' Загружаем буфер из ресурсов
    
    ReDim dll(88620)
    CopyMemory dll(0), buf(0), 88621 ' Копируем только 88621 байт
    
    If Crc32Api(dll) = &HF0E81CB6 Then ' Проверить CRC сжатого буфера
        If DeCompressDeltaB(dll) = True Then ' Распаковать буфер
            If Crc32Api(dll) = &HD3B58EB5 Then ' Проверить CRC распакованного буфера
                If UBound(dll) = 171007 Then ' Совпадает количество байт
                    On Error Resume Next
                    
                    Err.Clear
                    FileNo = FreeFile
                    
                    Open App.Path + "\zlibwapi.dll" For Binary As FileNo
                        Put #FileNo, , dll
                    Close FileNo
                    
                    If Err.Number = 0 Then CreatingDLL = True
                End If
            End If
        End If
    End If
End Function
 
Private Sub Command1_Click()
    Dim tick As Long
    Dim result As Boolean
    
    If IsDLLFunction("zlibwapi.dll", "zlibVersion") = False Then ' Не найдена библиотека либо функция в библиотеке
        tick = GetTickCount
        result = CreatingDLL ' Создать DLL
        Print GetTickCount - tick & " ml" ' Измерить время (у меня 0 млск)
        
        MsgBox "Создание библиотеки: " & result
    End If
End Sub

Option Explicit
Private Declare Function RtlComputeCrc32 Lib "ntdll.dll" (ByVal dwInitial As Long, ByVal pData As Long, ByVal iLen As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetTickCount Lib "kernel32" () As Long
 
Private Function Crc32Api(tBuff() As Byte) As Long
    Crc32Api = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
End Function
 
Private Function CreatingDLL() As Boolean
    Dim FileNo As Integer
    Dim buf() As Byte
    Dim dll() As Byte
    
    buf = LoadResData(101, "DELTA") ' Загружаем буфер из ресурсов
    
    ReDim dll(39669)
    CopyMemory dll(0), buf(0), 39670 ' Копируем только 39670 байт
    
    If Crc32Api(dll) = &H4039D04F Then ' Проверить CRC сжатого буфера
        If DeCompressDeltaB(dll) = True Then ' Распаковать буфер
            If Crc32Api(dll) = &H5146E353 Then ' Проверить CRC распакованного буфера
                On Error Resume Next
                
                Err.Clear
                FileNo = FreeFile
                
                Open App.Path + "\zlibwapi.dll" For Binary As FileNo
                    Put #FileNo, , dll
                Close FileNo
                
                If Err.Number = 0 Then CreatingDLL = True
            End If
        End If
    End If
End Function
 
Private Sub Command1_Click()
    Dim tick As Long
    Dim result As Boolean
    
    ' Здесь производится поиск dll-библиотеки и в системных папках (C:\Windows\System32 и т. д.) и в папке с программой
    If IsDLLFunction("zlibwapi.dll", "zlibVersion") = False Then ' Не найдена библиотека либо функция в библиотеке
        tick = GetTickCount
        result = CreatingDLL ' Создать DLL
        Print GetTickCount - tick & " ml" ' Измерить время (у меня 0 млск)
        
        MsgBox "Создание библиотеки: " & result
    End If
End Sub

Option Explicit
Private Declare Function RtlComputeCrc32 Lib "ntdll.dll" (ByVal dwInitial As Long, ByVal pData As Long, ByVal iLen As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
 
Private Function Crc32Api(tBuff() As Byte) As Long
    Crc32Api = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
End Function
 
Private Function CreatingDLL() As Boolean
    Dim FileNo As Integer
    Dim buf() As Byte
    Dim dll() As Byte
    
    dll = LoadResData(101, "DELTA") ' Загружаем буфер из ресурсов
    ReDim Preserve dll(39669) ' Отрезать только 39670 байт (без Preserve не работает! сбвивается CRC)
    
    If Crc32Api(dll) = &H4039D04F Then ' Проверить CRC сжатого буфера
        If DeCompressDeltaB(dll) = True Then ' Распаковать буфер
            If Crc32Api(dll) = &H5146E353 Then ' Проверить CRC распакованного буфера
                On Error Resume Next
                
                Err.Clear
                FileNo = FreeFile
                
                Open App.Path + "\zlibwapi.dll" For Binary As FileNo
                    Put #FileNo, , dll
                Close FileNo
                
                If Err.Number = 0 Then CreatingDLL = True
            End If
        End If
    End If
End Function
 
Private Sub Command1_Click()
    Dim tick As Long
    Dim result As Boolean
    
    ' Здесь производится поиск dll-библиотеки и в системных папках (C:\Windows\System32 и т. д.) и в папке с программой
    If IsDLLFunction("zlibwapi.dll", "zlibVersion") = False Then ' Не найдена библиотека либо функция в библиотеке
        tick = GetTickCount
        result = CreatingDLL ' Создать DLL
        Print GetTickCount - tick & " ml" ' Измерить время (у меня 0 млск)
        
        MsgBox "Создание библиотеки: " & result
    End If
End Sub