Leandro Ascierto

Estas dos funciones sirven para comprimir y descomprimir un array de una forma muy rápida y según el caso puede reducirle el tamaño hasta 10 veces, esto depende del tamaño del mismo o si los datos que este contengan no están comprimidos (por ejemplo no comprimirá el array de una imágen .JPG o un archivo .ZIP, si de una imágen BMP un archivo .EXE). las funciones utilizan las Apis de NTDLL.DLL

* Nota:  Algunos antivirus detectan estas Apis como una posible amenaza, es un dato para tener en cuenta si alguna vez la aplicación es marcada como un virus.

Option Explicit
Private Declare Function RtlGetCompressionWorkSpaceSize Lib "NTDLL" (ByVal flags As Integer, WorkSpaceSize As Long, UNKNOWN_PARAMETER As Long) As Long
Private Declare Function NtAllocateVirtualMemory Lib "ntdll.dll" (ByVal ProcHandle As Long, BaseAddress As Long, ByVal NumBits As Long, regionsize As Long, ByVal flags As Long, ByVal ProtectMode As Long) As Long
Private Declare Function RtlCompressBuffer Lib "NTDLL" (ByVal flags As Integer, ByVal BuffUnCompressed As Long, ByVal UnCompSize As Long, ByVal BuffCompressed As Long, ByVal CompBuffSize As Long, ByVal UNKNOWN_PARAMETER As Long, OutputSize As Long, ByVal WorkSpace As Long) As Long
Private Declare Function RtlDecompressBuffer Lib "NTDLL" (ByVal flags As Integer, ByVal BuffUnCompressed As Long, ByVal UnCompSize As Long, ByVal BuffCompressed As Long, ByVal CompBuffSize As Long, OutputSize As Long) As Long
Private Declare Function NtFreeVirtualMemory Lib "ntdll.dll" (ByVal ProcHandle As Long, BaseAddress As Long, regionsize As Long, ByVal flags As Long) As Long

Public Function Compress(Data() As Byte, Out() As Byte) As Long
    Dim WorkSpaceSize As Long
    Dim WorkSpace As Long
    ReDim Out(UBound(Data) * 1.13 + 4)

    RtlGetCompressionWorkSpaceSize 2, WorkSpaceSize, 0
    NtAllocateVirtualMemory -1, WorkSpace, 0, WorkSpaceSize, 4096, 64
    RtlCompressBuffer 2, VarPtr(Data(0)), UBound(Data) + 1, VarPtr(Out(0)), (UBound(Data) * 1.13 + 4), 0, Compress, WorkSpace
    NtFreeVirtualMemory -1, WorkSpace, 0, 16384
    ReDim Preserve Out(Compress)
End Function

Public Function DeCompress(Data() As Byte, dest() As Byte) As Long
    If UBound(Data) Then
        Dim lBufferSize As Long
        ReDim dest(UBound(Data) * 12.5)
        RtlDecompressBuffer 2, VarPtr(dest(0)), (UBound(Data) * 12.5), VarPtr(Data(0)), UBound(Data), lBufferSize
        If lBufferSize Then
            ReDim Preserve dest(lBufferSize - 1)
            DeCompress = lBufferSize - 1
        End If
    End If
End Function