[Módulos] - 5 métodos para comprimir archivos en VB

[_Sergi_]

Bueno aqui les dejo cinco módulos completos y listos para usar para comprimir archivos desde VB. Como es lógico tambien sirven para cifrar datos, pero esa no es su función principal.

Método 1: Base64

Código [Seleccionar] Expandir

Option Explicit

'This coder makes all the numbers <64
'it does this by stripping bit 0+1 of every byte and store those bits
'into a new byte
'so every 3 bytes will get an additional byte of 6 bits because
'we want this byte also to be <64
'The decoder reads the additional byte and substract the 6 bits
'from it and place them back into the original bytes


Public Sub FlattenTo64(ByteArray() As Byte)
    Dim codeBuf() As Byte
    Dim DecreaseBuf() As Byte
    Dim CodeTel As Long
    Dim DecrCode As Byte
    Dim Waarde As Integer
    Dim BitPos(7) As Byte
    Dim TelBits As Integer
    Dim FileLang As Long
    Dim X As Long
    Dim Y As Integer
    For X = 0 To 7
        BitPos(X) = 2 ^ X
    Next
    FileLang = UBound(ByteArray)
    ReDim DecreaseBuf(FileLang)
    ReDim codeBuf(FileLang / 3 + 3)
    DecrCode = 0
    CodeTel = -1
    TelBits = 0
    For X = 0 To FileLang
        Waarde = ByteArray(X)
        For Y = 1 To 2
            If (Waarde And 1) = 1 Then
                DecrCode = DecrCode Or BitPos(TelBits)
            End If
            Waarde = Int(Waarde / 2)
            TelBits = TelBits + 1
        Next
        DecreaseBuf(X) = Waarde
        If TelBits = 6 Then
            CodeTel = CodeTel + 1
            codeBuf(CodeTel) = DecrCode
            DecrCode = 0
            TelBits = 0
        End If
    Next
    If TelBits > 0 Then
        CodeTel = CodeTel + 1
        codeBuf(CodeTel) = DecrCode
    End If
    ReDim ByteArray(4 + CodeTel + FileLang)
    ByteArray(0) = Int(FileLang / &H1000000) And &HFF
    ByteArray(1) = Int(FileLang / &H10000) And &HFF
    ByteArray(2) = Int(FileLang / &H100) And &HFF
    ByteArray(3) = FileLang And &HFF
    Call CopyMem(ByteArray(4), codeBuf(0), CodeTel)
    Call CopyMem(ByteArray(CodeTel + 4), DecreaseBuf(0), FileLang + 1)
End Sub

Public Sub DeFlattenTo64(ByteArray() As Byte)
    Dim OutStream() As Byte
    Dim OutPos As Long
    Dim CodeTel As Long
    Dim Code As Byte
    Dim DecrCode As Byte
    Dim Waarde As Integer
    Dim BitPos(7) As Byte
    Dim TelBits As Integer
    Dim FileLang As Long
    Dim X As Long
    Dim Y As Integer
    Dim InpCodeByte As Long
    Dim InpOrgByte As Long
    For X = 0 To 7
        BitPos(X) = 2 ^ X
    Next
    For X = 0 To 3
        FileLang = FileLang * 256 + ByteArray(X)
    Next
    InpCodeByte = 4
    InpOrgByte = UBound(ByteArray) - FileLang
    If Int(InpOrgByte - Int((FileLang / 3))) <> InpCodeByte Then
        MsgBox "there was a problem in de Deflatter routine"
    End If
    ReDim OutStream(FileLang)
    OutPos = 0
    Code = ByteArray(InpCodeByte)
    InpCodeByte = InpCodeByte + 1
    TelBits = 2
    For X = InpOrgByte To UBound(ByteArray)
        Waarde = ByteArray(X)
        For Y = 1 To 2
            Waarde = Waarde * 2 + (-1 * ((Code And BitPos(TelBits - Y)) > 0))
        Next
        TelBits = TelBits + 2
        If TelBits = 8 Then
            TelBits = 2
            Code = ByteArray(InpCodeByte)
            InpCodeByte = InpCodeByte + 1
        End If
        OutStream(OutPos) = Waarde
        OutPos = OutPos + 1
    Next
    ReDim ByteArray(OutPos - 1)
    Call CopyMem(ByteArray(0), OutStream(0), OutPos)
End Sub




Método 2: EliasDelta

Código [Seleccionar] Expandir

Option Explicit

'This is a 1 run method

'This compressor makes use of the Elias Delta codes
'How This codes are build up you can see in the init section

Private LeadingZero(9) As Integer
Private DeltaCode(9) As Integer
Private BitsToFollow(9) As Integer
Private ValToAdd(9) As Integer
Private OutPos As Long
Private OutByteBuf As Byte
Private OutBitCount As Integer
Private InpPos As Long
Private ReadBitPos As Integer

Public Sub Compress_Elias_Delta(ByteArray() As Byte)
    Dim OutStream() As Byte
    Dim X As Long
    Call Init_Elias_Delta
    ReDim OutStream(UBound(ByteArray))
    For X = 0 To UBound(ByteArray)
        Call AddEliasToArray(OutStream, CLng(ByteArray(X)))
    Next
    Call AddEliasToArray(OutStream, 256)
    If OutBitCount > 0 Then
        Call AddBitsToArray(OutStream, 0, 8 - OutBitCount)
    End If
    ReDim ByteArray(OutPos)
    Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub

Public Sub DeCompress_Elias_Delta(ByteArray() As Byte)
    Dim OutStream() As Byte
    Dim Char As Integer
    Dim X As Long
    Call Init_Elias_Delta
    ReDim OutStream(UBound(ByteArray))
    Char = ReadEliasCode(ByteArray)
    Do While Char <> 256
        Call AddCharToArray(OutStream, Char)
        Char = ReadEliasCode(ByteArray)
    Loop
    OutPos = OutPos - 1
    ReDim ByteArray(OutPos)
    Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub

Private Sub Init_Elias_Delta()
    OutPos = 0
    OutByteBuf = 0
    OutBitCount = 0
    InpPos = 0
    ReadBitPos = 0
    LeadingZero(0) = 0: DeltaCode(0) = 1: BitsToFollow(0) = 0    '1                  =1         -7
    LeadingZero(1) = 1: DeltaCode(1) = 2: BitsToFollow(1) = 1    '010x               =2-3       -4
    LeadingZero(2) = 1: DeltaCode(2) = 3: BitsToFollow(2) = 2    '011xx              =4-7       -3
    LeadingZero(3) = 2: DeltaCode(3) = 4: BitsToFollow(3) = 3    '00100xxx           =8-15      0
    LeadingZero(4) = 2: DeltaCode(4) = 5: BitsToFollow(4) = 4    '00101xxxx          =16-31     +1
    LeadingZero(5) = 2: DeltaCode(5) = 6: BitsToFollow(5) = 5    '00110xxxxx         =32-63     +2
    LeadingZero(6) = 2: DeltaCode(6) = 7: BitsToFollow(6) = 6    '00111xxxxxx        =64-127    +3
    LeadingZero(7) = 3: DeltaCode(7) = 1: BitsToFollow(7) = 7    '0001xxxxxxx        =128-255   +3
    LeadingZero(8) = 4: DeltaCode(8) = 1: BitsToFollow(8) = 0    '00001              =256       -3
    LeadingZero(9) = 4: DeltaCode(9) = 0: BitsToFollow(9) = 0    '00000              =257       +5  EOF
    ValToAdd(0) = 1
    ValToAdd(1) = 2
    ValToAdd(2) = 4
    ValToAdd(3) = 8
    ValToAdd(4) = 16
    ValToAdd(5) = 32
    ValToAdd(6) = 64
    ValToAdd(7) = 128
    ValToAdd(8) = 0
    ValToAdd(9) = 0
End Sub

Private Function Get_Elias_Code(Number As Long) As Integer
    Select Case Number
    Case 1
        Get_Elias_Code = 0
    Case Is < 4
        Get_Elias_Code = 1
    Case Is < 8
        Get_Elias_Code = 2
    Case Is < 16
        Get_Elias_Code = 3
    Case Is < 32
        Get_Elias_Code = 4
    Case Is < 64
        Get_Elias_Code = 5
    Case Is < 128
        Get_Elias_Code = 6
    Case Is < 256
        Get_Elias_Code = 7
    Case Is = 256
        Get_Elias_Code = 8
    Case Else
        Get_Elias_Code = 9
    End Select
End Function

Private Sub AddEliasToArray(Toarray() As Byte, Char As Long)
    Dim Code As Integer
    Dim X As Integer
    Dim BitSize As Integer
    Char = Char + 1
    Code = Get_Elias_Code(Char)
    Call AddBitsToArray(Toarray, 0, LeadingZero(Code))
    Select Case DeltaCode(Code)
    Case Is < 2
        BitSize = 1
    Case Is < 4
        BitSize = 2
    Case Is < 8
        BitSize = 3
    Case Else
        BitSize = 1
    End Select
    Call AddBitsToArray(Toarray, CLng(DeltaCode(Code)), BitSize)
    Call AddBitsToArray(Toarray, Char, BitsToFollow(Code))
End Sub

Private Function ReadEliasCode(FromArray() As Byte) As Integer
    Dim X As Integer
    Dim Temp As Integer
    Dim DeltaCode As Integer
    Dim bitcount As Integer
    Do While ReadBitsFromArray(FromArray, InpPos, 1) = 0 And bitcount < 5
        bitcount = bitcount + 1
    Loop
    If bitcount = 5 Then ReadEliasCode = 256: Exit Function
    If bitcount = 4 Then ReadEliasCode = 255: Exit Function
    If bitcount = 3 Then
        DeltaCode = 7
    Else
        DeltaCode = 2 ^ bitcount + ReadBitsFromArray(FromArray, InpPos, bitcount) - 1
    End If
    Temp = ValToAdd(DeltaCode) + ReadBitsFromArray(FromArray, InpPos, BitsToFollow(DeltaCode))
    ReadEliasCode = Temp - 1
End Function

'this sub will add an amount of bits into the outputstream
Private Sub AddBitsToArray(Toarray() As Byte, Number As Long, Numbits As Integer)
    Dim X As Long
    For X = Numbits - 1 To 0 Step -1
        OutByteBuf = OutByteBuf * 2 + (-1 * ((Number And 2 ^ X) > 0))
        OutBitCount = OutBitCount + 1
        If OutBitCount = 8 Then
            Toarray(OutPos) = OutByteBuf
            OutBitCount = 0
            OutByteBuf = 0
            OutPos = OutPos + 1
            If OutPos > UBound(Toarray) Then
                ReDim Preserve Toarray(OutPos + 500)
            End If
        End If
    Next
End Sub

Private Sub AddCharToArray(Toarray() As Byte, Char As Integer)
    If OutPos > UBound(Toarray) Then
        ReDim Preserve Toarray(OutPos + 100)
    End If
    Toarray(OutPos) = Char
    OutPos = OutPos + 1
End Sub

Private Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, Numbits As Integer) As Long
    Dim X As Integer
    Dim Temp As Long
    For X = 1 To Numbits
        Temp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - ReadBitPos)) > 0))
        ReadBitPos = ReadBitPos + 1
        If ReadBitPos = 8 Then
            If FromPos + 1 > UBound(FromArray) Then
                Do While X < Numbits
                    Temp = Temp * 2
                    X = X + 1
                Loop
                FromPos = FromPos + 1
                Exit For
            End If
            FromPos = FromPos + 1
            ReadBitPos = 0
        End If
    Next
    ReadBitsFromArray = Temp
End Function

[_Sergi_]

Método 3: Fibonacci

Código [Seleccionar] Expandir

Option Explicit

'This is a 1 run method

'This compressor makes use of the Fibonacci codes
'How This codes are build up you can see in the init section

Private Type Fibonacci_Code
    LeadingZero As Integer
    Value As Long
End Type

Private BitNumVal(11) As Integer
Private Fibonacci(257) As Fibonacci_Code
Private OutPos As Long
Private OutByteBuf As Byte
Private OutBitCount As Integer
Private InpPos As Long
Private ReadBitPos As Integer

Private Sub Init_Fibonacci_code()
'    1  2  3  5  8  13 21 34 55 89 144 233
'   --------------------------------------------
'    1 (1)                                          =1
'    0  1 (1)                                       =2
'    0  0  1 (1)                                    =3
'    1  0  1 (1)                                    =4
'    0  0  0  1 (1)                                 =5
'    1  0  0  1  0  0  1 (1)                        =27
'    0  0  1  0  1  0  1 (1)                        =32
'  =       3  +  8  +  21 =                         =32
    BitNumVal(0) = 1
    BitNumVal(1) = 2
    BitNumVal(2) = 3
    BitNumVal(3) = 5
    BitNumVal(4) = 8
    BitNumVal(5) = 13
    BitNumVal(6) = 21
    BitNumVal(7) = 34
    BitNumVal(8) = 55
    BitNumVal(9) = 89
    BitNumVal(10) = 144
    BitNumVal(11) = 233
    OutPos = 0
    OutByteBuf = 0
    OutBitCount = 0
    InpPos = 0
    ReadBitPos = 0
End Sub

Private Sub Create_Fibonacci_Codes()
    Dim Temp As String
    Dim X As Integer
    Dim Y As Integer
    Dim Value As Integer
    Dim bitcount As Integer
    Call Init_Fibonacci_code
    For Y = 1 To 257
        Value = Y
        Fibonacci(Y).LeadingZero = 0
        Fibonacci(Y).Value = 1
        bitcount = 0
        For X = 11 To 0 Step -1
            If Value - BitNumVal(X) < 0 Then
                If Fibonacci(Y).Value > 1 Then
                    Fibonacci(Y).LeadingZero = Fibonacci(Y).LeadingZero + 1
                End If
            Else
                bitcount = bitcount + 1
                Fibonacci(Y).Value = Fibonacci(Y).Value + 2 ^ bitcount
                Fibonacci(Y).LeadingZero = -1 * (X > 0)
                Value = Value - BitNumVal(X)
                X = X - 1
            End If
            If bitcount > 0 Then
                bitcount = bitcount + 1
            End If
        Next
    Next
End Sub

Public Sub Compress_Fibonacci(ByteArray() As Byte)
    Dim OutStream() As Byte
    Dim X As Long
    Call Create_Fibonacci_Codes
    ReDim OutStream(UBound(ByteArray))
    For X = 0 To UBound(ByteArray)
        Call AddFibonacciToArray(OutStream, CLng(ByteArray(X)))
    Next
    Call AddFibonacciToArray(OutStream, 256)
    If OutBitCount > 0 Then
        Call AddBitsToArray(OutStream, 0, 8 - OutBitCount)
    End If
    ReDim ByteArray(OutPos)
    Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub

Public Sub DeCompress_Fibonacci(ByteArray() As Byte)
    Dim OutStream() As Byte
    Dim Char As Integer
    Dim X As Long
    Call Init_Fibonacci_code
    ReDim OutStream(UBound(ByteArray))
    Char = ReadFibonacciCode(ByteArray)
    Do While Char <> 256
        Call AddCharToArray(OutStream, Char)
        Char = ReadFibonacciCode(ByteArray)
    Loop
    OutPos = OutPos - 1
    ReDim ByteArray(OutPos)
    Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub

Private Sub AddFibonacciToArray(Toarray() As Byte, Char As Long)
    Dim X As Integer
    Dim bitcount As Integer
    Char = Char + 1
    For bitcount = 0 To 14
        If Fibonacci(Char).Value < 2 ^ bitcount Then
            Exit For
        End If
    Next
    Call AddBitsToArray(Toarray, 0, Fibonacci(Char).LeadingZero)
    Call AddBitsToArray(Toarray, Fibonacci(Char).Value, bitcount)
End Sub

Private Function ReadFibonacciCode(FromArray() As Byte) As Integer
    Dim bitcount As Integer
    Dim Temp As Integer
    Dim BitVal As Integer
    Dim LastCode As Boolean
    LastCode = False
    Do
        BitVal = ReadBitsFromArray(FromArray, InpPos, 1)
        If BitVal = 1 Then
            If LastCode = True Then
                Exit Do
            Else
                LastCode = True
            End If
            Temp = Temp + BitNumVal(bitcount)
        Else
            LastCode = False
        End If
        bitcount = bitcount + 1
    Loop
    ReadFibonacciCode = Temp - 1
End Function

'this sub will add an amount of bits into the outputstream
Private Sub AddBitsToArray(Toarray() As Byte, Number As Long, Numbits As Integer)
    Dim X As Long
    For X = Numbits - 1 To 0 Step -1
        OutByteBuf = OutByteBuf * 2 + (-1 * ((Number And 2 ^ X) > 0))
        OutBitCount = OutBitCount + 1
        If OutBitCount = 8 Then
            Toarray(OutPos) = OutByteBuf
            OutBitCount = 0
            OutByteBuf = 0
            OutPos = OutPos + 1
            If OutPos > UBound(Toarray) Then
                ReDim Preserve Toarray(OutPos + 500)
            End If
        End If
    Next
End Sub

Private Sub AddCharToArray(Toarray() As Byte, Char As Integer)
    If OutPos > UBound(Toarray) Then
        ReDim Preserve Toarray(OutPos + 100)
    End If
    Toarray(OutPos) = Char
    OutPos = OutPos + 1
End Sub

Private Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, Numbits As Integer) As Long
    Dim X As Integer
    Dim Temp As Long
    For X = 1 To Numbits
        Temp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - ReadBitPos)) > 0))
        ReadBitPos = ReadBitPos + 1
        If ReadBitPos = 8 Then
            If FromPos + 1 > UBound(FromArray) Then
                Do While X < Numbits
                    Temp = Temp * 2
                    X = X + 1
                Loop
                FromPos = FromPos + 1
                Exit For
            End If
            FromPos = FromPos + 1
            ReadBitPos = 0
        End If
    Next
    ReadBitsFromArray = Temp
End Function



Método 4: GroupSmart

Código [Seleccionar] Expandir


Option Explicit

'This is a 1 run method

'This method is the smartgrouping method
'it will search for follower bytes within a curtain range wich
'will fit into a curtain bitlenght
'It will search as long as needed to find the best compression
'if it finds followers of 12*0 and 4*1 = 16 bytes it will be compressed
'because 0 - 0 and 1 - 0 will both fit into 1 bit, it will fit
'in 16*1 bit wich will lead to to the following
'in 17 headerbits and 16 codebits = 33 bits = 4 bytes and 1 bit
'if it finds followers of 12*0 and 4*173 = 16 bytes it will be compressed
'because 0 - 0 will fit in 1 bit and 173 - 173 will fit into 1 bit it will fit
'in 12*1 bit and 4*1 bit wich will lead to to the following
'in 17 headerbits and 12 codebits = 29 bits = 3 bytes and 5 bits
'in 17 headerbits and 4 codebits = 21 bits = 2 bytes and 3 bits
'wich get a total of 6 bytes

Private OutPos As Long              'invoeg positie voor de output array
Private OutBitCount As Integer
Private OutByteBuf As Byte
Private ReadBitPos As Integer
Private NumExtBits(7) As Byte

Private Type Grouping
    LowValue As Long
    HighValue As Long
    NumInGroup As Long
End Type
   
Private Sub Init_Grouping()
    OutPos = 0              'Next position in the output stream
    OutBitCount = 0         'Number of bits stored in the output buffer
    OutByteBuf = 0          'byte wich will be stores in outputstream if it is filled with 8 bits
    ReadBitPos = 0          'next position wich will be read
'This array is used to determen the amount of bits used to store a number
    NumExtBits(0) = 3       '<8
    NumExtBits(1) = 3       '<16
    NumExtBits(2) = 4       '<32
    NumExtBits(3) = 5       '<64
    NumExtBits(4) = 6       '<128
    NumExtBits(5) = 7       '<256
    NumExtBits(6) = 8       '<512
    NumExtBits(7) = 16      'the rest
End Sub

Public Sub Compress_SmartGrouping(ByteArray() As Byte)
    Dim OutStream() As Byte         'The output array
    Dim BeginGroup As Long          'Start for the next bytes wich will be compressed
    Dim BestGroup As Integer        'Best grouping method to get the best result
    Dim NewBest As Integer          'used to check if there is maybe a better method
    Dim BitsDeep As Integer         'This is used as a dummy
    Dim X As Long
    Dim TotFileLen As Long          'total file len
    Dim Group(1 To 8) As Grouping
    TotFileLen = UBound(ByteArray)
    ReDim OutStream(TotFileLen + (TotFileLen / 7))  'Worst case scenario
    BeginGroup = 0
'whe start by setting the beginvalues
    Call Init_Grouping
'lets check if we have done the whole file
    Do While BeginGroup < TotFileLen
        Group(8).LowValue = 0
        Group(8).HighValue = 255
        Group(8).NumInGroup = TotFileLen - BeginGroup + 1
'If where not ready yet whe assume the best method of compression is no compression
'That is indeed the best method cause nocompression needs 9 additional bits and compression uses 17
        BestGroup = 8
'lets check if there is maybe a better way
        NewBest = CheckForBetterWithin(ByteArray, Group, BestGroup, BeginGroup)
        Do While BestGroup <> NewBest
'yes there is, lets check again to be shure
            BestGroup = NewBest
            NewBest = CheckForBetterWithin(ByteArray, Group, BestGroup, BeginGroup)
        Loop
'whe have found the best method
        If BestGroup = 8 Then
            BitsDeep = 0            'No compression
        Else
            BitsDeep = BestGroup
        End If
'here we will store the header in into the outputstream
        Call AddGroupCodeToStream(OutStream, Group(BestGroup).NumInGroup, BitsDeep)
'If we have found compression then we must store also the lowest value of the group
'opslaan minimum waarde van de groep
        If BestGroup <> 8 Then
            Call AddBitsToStream(OutStream, CLng(Group(BestGroup).LowValue), 8)
        End If
'here we will read the bytes from the inputstream, convert them, and store them
'into the output stream
        For X = BeginGroup To BeginGroup + Group(BestGroup).NumInGroup - 1
            Call AddBitsToStream(OutStream, CLng(ByteArray(X) - Group(BestGroup).LowValue), BestGroup)
        Next
        BeginGroup = BeginGroup + Group(BestGroup).NumInGroup
    Loop
'if the grouping part is complete we have to store the EOF-marker = 0
'0 = no compression ,marker for less than 8 bytes, and 0 bytes to store
    Call AddGroupCodeToStream(OutStream, 0, 0)
'maybe we have some bits leftover so lets store them
    If OutBitCount < 8 Then
        Do While OutBitCount < 8
            OutByteBuf = OutByteBuf * 2
            OutBitCount = OutBitCount + 1
        Loop
        OutStream(OutPos) = OutByteBuf: OutPos = OutPos + 1
    End If
    OutPos = OutPos - 1
    ReDim ByteArray(OutPos)
'lets copy the outputstream into the inputstream so that we can return the compressed file
'to the caller
    Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub

'This part is used to select the extra bits used to store a value
Private Function GetExtraBitsNum(Number As Long)
    Select Case Number
    Case Is < 8
        GetExtraBitsNum = 0
    Case Is < 16
        GetExtraBitsNum = 1
    Case Is < 32
        GetExtraBitsNum = 2
    Case Is < 64
        GetExtraBitsNum = 3
    Case Is < 128
        GetExtraBitsNum = 4
    Case Is < 256
        GetExtraBitsNum = 5
    Case Is < 512
        GetExtraBitsNum = 6
    Case Else
        GetExtraBitsNum = 7
    End Select
End Function

Private Sub AddGroupCodeToStream(ToStream() As Byte, Number As Long, GroupNum As Integer)
    Dim NumVal As Byte
    Dim X As Long
'Store 3 bits to say what grouping method is used
    Call AddBitsToStream(ToStream, CLng(GroupNum), 3)
    NumVal = GetExtraBitsNum(Number)
'store 3 bits to with will tell the amount of bits to be read to get the groupsize
    Call AddBitsToStream(ToStream, CLng(NumVal), 3)
'store 3 to 16 bits to put in the groepsize
    Call AddBitsToStream(ToStream, Number, CInt(NumExtBits(NumVal)))
End Sub

'this sub will add an amount of bits into the outputstream
Private Sub AddBitsToStream(ToStream() As Byte, Number As Long, Numbits As Integer)
    Dim X As Long
    For X = Numbits - 1 To 0 Step -1
        OutByteBuf = OutByteBuf * 2 + (-1 * ((Number And 2 ^ X) > 0))
        OutBitCount = OutBitCount + 1
        If OutBitCount = 8 Then: ToStream(OutPos) = OutByteBuf: OutBitCount = 0: OutByteBuf = 0: OutPos = OutPos + 1
    Next
End Sub

'This is Smart part of the grouping method
'it will look for the way to get the best compression
Private Function CheckForBetterWithin(InArray() As Byte, Group() As Grouping, MaxGroup As Integer, StartPositie As Long)
    Dim LowInGroup As Integer               'lowest value found
    Dim HighInGroup As Integer              'highest value found
    Dim GroupSize As Integer                'size of the group 1-7
    Dim NumInGroup As Long                  'total numbers in group
    Dim RealBegin As Long
    Dim BestGroep As Integer                'the best group found
    Dim NewBestGroep As Integer             'check for bestgroup
    Dim StartGroep As Integer               'startgroup to hold the group wich will be checked for better comp.
    Dim BestCompression As Long             'maximum compression (for now)
    Dim WheHaveCompression As Boolean       'whe have found a better method
    Dim Char As Integer                     'character found in input stream
    Dim BitsNoComp As Long                  'bits used if no comp.
    Dim BitsComp As Long                    'bits used if comp.
    Dim CheckLen As Long                    'maximum bytes to check
    Dim StartPos As Long                    'startposition where the check will start
    StartPos = StartPositie
    RealBegin = StartPos
    StartGroep = MaxGroup
    CheckForBetterWithin = MaxGroup
    BestCompression = 0
    If MaxGroup = 1 Then Exit Function          'better than the use of 1 bit ????
    Do While StartPos + NumInGroup <= RealBegin + Group(StartGroep).NumInGroup - 1
        CheckLen = RealBegin - StartPos + Group(StartGroep).NumInGroup - 1
'if ther are less then 3 bytes to check we exit
        If CheckLen < 3 Then Exit Function
        WheHaveCompression = False
        GroupSize = 1                   'Lets start with the minimal groupsize
        Group(GroupSize).LowValue = InArray(StartPos + NumInGroup)
        Group(GroupSize).HighValue = InArray(StartPos + NumInGroup)
'check if we don't check the group we started with
        Do While (GroupSize < StartGroep) And (NumInGroup < 65535)
            NumInGroup = NumInGroup + 1
            Group(GroupSize).NumInGroup = NumInGroup
'if we are at the end of the group we exit
            If StartPos + NumInGroup > RealBegin + Group(StartGroep).NumInGroup - 1 Then GoSub Calc_Compression: Exit Do
            Char = InArray(StartPos + NumInGroup)
            If Char < Group(GroupSize).LowValue Then
                If Group(GroupSize).HighValue - Char >= 2 ^ GroupSize Then
                    GoSub Calc_Compression              'we have have found the maximum numer in the group
                    If GroupSize < StartGroep - 1 Then
'why start over again for the next group
'if the number 15 will fit in 4 bits it shure will fit in 5
                        Group(GroupSize + 1).LowValue = Group(GroupSize).LowValue
                        Group(GroupSize + 1).HighValue = Group(GroupSize).HighValue
                    End If
                    GroupSize = GroupSize + 1
                Else
                    Group(GroupSize).LowValue = Char
                End If
            ElseIf Char > Group(GroupSize).HighValue Then
                If Char - Group(GroupSize).LowValue >= 2 ^ GroupSize Then
                    GoSub Calc_Compression
                    If GroupSize < StartGroep - 1 Then
                        Group(GroupSize + 1).LowValue = Group(GroupSize).LowValue
                        Group(GroupSize + 1).HighValue = Group(GroupSize).HighValue
                    End If
                    GroupSize = GroupSize + 1
                Else
                    Group(GroupSize).HighValue = Char
                End If
            End If
        Loop
        If WheHaveCompression = True Then
            If RealBegin = StartPos Then
'if the beginning of the group is the same we startted with we have found a best group and leave
                CheckForBetterWithin = BestGroep
                Exit Function
            Else
'if not, then we have to check if there is maybe a compression possible in the part between
'the start of the file and the start of the new found bestgroep (again we start with no compression)
                Group(8).NumInGroup = StartPos - RealBegin
                BestGroep = 8
                NewBestGroep = CheckForBetterWithin(InArray, Group, 8, RealBegin)
                Do While BestGroep <> NewBestGroep
                    BestGroep = NewBestGroep
                    NewBestGroep = CheckForBetterWithin(InArray, Group, BestGroep, RealBegin)
                Loop
                CheckForBetterWithin = BestGroep
                Exit Function
            End If
        Else
'if we didn't find compression then maybe there is a part further up in the file that achieves
'even better compression
            StartPos = StartPos + 1
            NumInGroup = 0
        End If
    Loop
    Exit Function
Calc_Compression:
'bits needed if we dont do compression or maybe did already
'3 for the compression method
'3 for the number with will tell the amount of next bits to read
'? numbers of bits needed to store the number of groupsize
'if whe already would do it with compression we need 8 bits for the lowvalue
'plus ofcourse the numbers of bits needed to store the group
    If CheckLen > 65535 Then CheckLen = 65535
    BitsNoComp = 3 + 3 + NumExtBits(GetExtraBitsNum(Group(GroupSize).NumInGroup)) + (8 * Abs(MaxGroup < 8)) + (Group(GroupSize).NumInGroup * 8) - (Group(GroupSize).NumInGroup * (8 - MaxGroup))
'bits needed to store compression
'3 for method,3 for bits needed,the groupsize,8 bits for lowest value and the group itself
    BitsComp = 3 + 3 + NumExtBits(GetExtraBitsNum(Group(GroupSize).NumInGroup)) + (8 * Abs(GroupSize < 8)) + (Group(GroupSize).NumInGroup * 8) - (Group(GroupSize).NumInGroup * (8 - GroupSize))
'if the new groep falls within the range of the old one whe also need to store the header the old group again
    If Group(GroupSize).NumInGroup <= Group(MaxGroup).NumInGroup Then BitsComp = BitsComp + 3 + 3 + NumExtBits(GetExtraBitsNum(CheckLen - StartPos - Group(GroupSize).NumInGroup)) + (8 * Abs(MaxGroup < 8))
'if the start position of the new group is different whe also need the store a new header for that group
    If StartPos <> RealBegin Then BitsComp = BitsComp + 3 + 3 + NumExtBits(GetExtraBitsNum(RealBegin - StartPos)) ' + (8 * Abs(MaxGroup < 8))
    NumInGroup = NumInGroup - 1
'if it is still better than the old method then whe have found a new group
    If BitsComp < BitsNoComp Then
        If BestCompression < BitsNoComp - BitsComp Then
            BestCompression = BitsNoComp - BitsComp
            WheHaveCompression = True
            BestGroep = GroupSize
        End If
    End If
    Return
End Function

'this peace of code is very strait forward
Public Sub DeCompress_SmartGrouping(ByteArray() As Byte)
    Dim AddFileLen As Long
    Dim OutStream() As Byte         'de output array
    Dim InpPos As Long
    Dim NewPos As Long
    Dim MaxPos As Long
    Dim PackedOrNot As Integer
    Dim NumBytes As Long
    Dim LowInGroup As Integer       'Laagste waarde in de groep
    Dim NumVal As Byte
    Dim X As Long
    AddFileLen = UBound(ByteArray) / 4
    ReDim OutStream(UBound(ByteArray) + AddFileLen)
    MaxPos = UBound(OutStream)
    InpPos = 0
    NewPos = 0
    Call Init_Grouping
    Do                                                              'loop until done
'read 3 bits to get grouping method (0 = not grouped)
        PackedOrNot = ReadBitsFromArray(ByteArray, InpPos, 3)
'read 3 bits to get the bits needed for the groupsize
        NumVal = ReadBitsFromArray(ByteArray, InpPos, 3)
'read the amount of data needed for the group
        NumBytes = ReadBitsFromArray(ByteArray, InpPos, CInt(NumExtBits(NumVal)))
'add an extra bit if needed (number 15 fits in 3 bits)
        If NumVal > 0 And NumVal < 7 Then
            NumBytes = NumBytes Or 2 ^ (NumVal + 2)
        End If
        If NumBytes = 0 Then Exit Do            'whe are done
        If PackedOrNot = 0 Then
'if not grouped, read the amount of nongrouped data (8 bits)
            For X = 1 To NumBytes       'de bytes zijn niet geGrouped
                If NewPos > MaxPos Then GoSub Increase_Outstream
                OutStream(NewPos) = ReadBitsFromArray(ByteArray, InpPos, 8)
                NewPos = NewPos + 1
            Next
        Else
'if grouped, read the lowest value in the group
            LowInGroup = ReadBitsFromArray(ByteArray, InpPos, 8)
'and get the amount of data for that group
            For X = 1 To NumBytes       'de bytes zijn  geGrouped
                If NewPos > MaxPos Then GoSub Increase_Outstream
                OutStream(NewPos) = ReadBitsFromArray(ByteArray, InpPos, PackedOrNot) + LowInGroup
                NewPos = NewPos + 1
            Next
        End If
    Loop
    NewPos = NewPos - 1
    ReDim ByteArray(NewPos)
'copy the temporary outputstream into the input stream to return it to the caller
    Call CopyMem(ByteArray(0), OutStream(0), NewPos + 1)
    Exit Sub
   
Increase_Outstream:
'this is used if the reserved amount of store space wasn't sufficient
    ReDim Preserve OutStream(NewPos + AddFileLen)
    MaxPos = UBound(OutStream)
    Return
End Sub

'this function will return a value out of the amaunt of bits you asked for
Private Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, Numbits As Integer) As Long
    Dim X As Integer
    Dim Temp As Long
    For X = 1 To Numbits
        Temp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - ReadBitPos)) > 0))
        ReadBitPos = ReadBitPos + 1
        If ReadBitPos = 8 Then
            If FromPos + 1 > UBound(FromArray) Then
                Do While X < Numbits
                    Temp = Temp * 2
                    X = X + 1
                Loop
                FromPos = FromPos + 1
                Exit For
            End If
            FromPos = FromPos + 1
            ReadBitPos = 0
        End If
    Next
    ReadBitsFromArray = Temp
End Function

[_Sergi_]

Método 5: VBC

Código [Seleccionar] Expandir

Option Explicit

'This is a 2 run method

Private OutPos As Long
Private OutByteBuf As Integer
Private OutBitCount As Integer
Private ReadBitPos As Integer
Private ExtraBits(7) As Integer
Private MinValToAdd(7) As Integer
Private LastChar As Byte

Public Sub Compress_VBC(ByteArray() As Byte)
    Dim X As Long
    Dim OutStream() As Byte
    Dim CharCount(255) As Long
    Dim NewLen As Long
    Dim Char As Byte
    Dim ExtBits As Integer
    Call Init_VBC
    LastChar = 0
    For X = 0 To UBound(ByteArray)
        CharCount(ByteArray(X)) = CharCount(ByteArray(X)) + 1
    Next
    For X = 0 To 255
        If CharCount(X) > 0 Then
            NewLen = NewLen + ((3 + getBitSize(CByte(X))) * CharCount(X))
        End If
    Next
    NewLen = Int(NewLen / 8) + 1
    ReDim OutStream(NewLen)         'worst case scenario
    For X = 0 To UBound(ByteArray)
        Char = ByteArray(X)
        ExtBits = getBitSize(Char)
        Call AddBitsToArray(OutStream, CLng(ExtBits), 3)
        If ExtBits <> 0 Then
            Call AddBitsToArray(OutStream, CLng(Char), ExtraBits(ExtBits))
        End If
        LastChar = Char
    Next
'maybe we have some bits leftover so lets store them
    If OutBitCount < 8 Then
        Do While OutBitCount < 8
            OutByteBuf = OutByteBuf * 2
            OutBitCount = OutBitCount + 1
        Loop
        OutStream(OutPos) = OutByteBuf: OutPos = OutPos + 1
    End If
    OutPos = OutPos - 1
    NewLen = UBound(ByteArray)
    ReDim ByteArray(OutPos + 4)
    ByteArray(0) = Int(NewLen / &H1000000) And &HFF
    ByteArray(1) = Int(NewLen / &H10000) And &HFF
    ByteArray(2) = Int(NewLen / &H100) And &HFF
    ByteArray(3) = NewLen And &HFF
    Call CopyMem(ByteArray(4), OutStream(0), OutPos + 1)
End Sub

Public Sub DeCompress_VBC(ByteArray() As Byte)
    Dim X As Long
    Dim OutStream() As Byte
    Dim InpPos As Long
    Dim FileLang As Long
    Dim Char As Byte
    Dim ExtBits As Integer
    Call Init_VBC
    LastChar = 0
    For X = 0 To 3
        FileLang = FileLang * 256 + ByteArray(X)
    Next
    InpPos = 4
    ReDim OutStream(FileLang)
    Do While OutPos < FileLang + 1
        ExtBits = ReadBitsFromArray(ByteArray, InpPos, 3)
        If ExtBits = 0 Then
            Char = LastChar
        Else
            Char = ReadBitsFromArray(ByteArray, InpPos, ExtraBits(ExtBits)) + MinValToAdd(ExtBits)
        End If
        Call AddCharToArray(OutStream, OutPos, Char)
        LastChar = Char
    Loop
    OutPos = OutPos - 1
    ReDim ByteArray(OutPos)
    Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub


Private Sub Init_VBC()
    OutPos = 0
    OutByteBuf = 0
    OutBitCount = 0
    ReadBitPos = 0
    ExtraBits(0) = 0    'Last Character +5
    MinValToAdd(0) = 0
    ExtraBits(1) = 3    '0-7            +2
    MinValToAdd(1) = 0
    ExtraBits(2) = 3    '8-15           +2
    MinValToAdd(2) = 8
    ExtraBits(3) = 4    '16-31          +1
    MinValToAdd(3) = 16
    ExtraBits(4) = 4    '32-47          +1
    MinValToAdd(4) = 32
    ExtraBits(5) = 4    '48-64          +1
    MinValToAdd(5) = 48
    ExtraBits(6) = 6    '64-127         -1
    MinValToAdd(6) = 64
    ExtraBits(7) = 7    '128-255        -2
    MinValToAdd(7) = 128
End Sub

Private Function getBitSize(Char As Byte) As Byte
    Select Case Char
        Case Is = LastChar
            getBitSize = 0
        Case Is < 8
            getBitSize = 1
        Case Is < 16
            getBitSize = 2
        Case Is < 32
            getBitSize = 3
        Case Is < 48
            getBitSize = 4
        Case Is < 64
            getBitSize = 5
        Case Is < 128
            getBitSize = 6
        Case Else
            getBitSize = 7
    End Select
End Function

'this sub will add an amount of bits into the outputstream
Private Sub AddBitsToArray(Toarray() As Byte, Number As Long, Numbits As Integer)
    Dim X As Long
    For X = Numbits - 1 To 0 Step -1
        OutByteBuf = OutByteBuf * 2 + (-1 * ((Number And 2 ^ X) > 0))
        OutBitCount = OutBitCount + 1
        If OutBitCount = 8 Then
            Toarray(OutPos) = OutByteBuf
            OutBitCount = 0
            OutByteBuf = 0
            OutPos = OutPos + 1
            If OutPos > UBound(Toarray) Then
                ReDim Preserve Toarray(OutPos + 500)
            End If
        End If
    Next
End Sub

Private Sub AddCharToArray(Toarray() As Byte, ToPos As Long, Char As Byte)
    If ToPos > UBound(Toarray) Then
        ReDim Preserve Toarray(ToPos + 500)
    End If
    Toarray(ToPos) = Char
    ToPos = ToPos + 1
End Sub

Private Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, Numbits As Integer) As Long
    Dim X As Integer
    Dim Temp As Long
    For X = 1 To Numbits
        Temp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - ReadBitPos)) > 0))
        ReadBitPos = ReadBitPos + 1
        If ReadBitPos = 8 Then
            If FromPos + 1 > UBound(FromArray) Then
                Do While X < Numbits
                    Temp = Temp * 2
                    X = X + 1
                Loop
                FromPos = FromPos + 1
                Exit For
            End If
            FromPos = FromPos + 1
            ReadBitPos = 0
        End If
    Next
    ReadBitsFromArray = Temp
End Function



Espero que les sean de utilidad, sobre la autoría de los mismos, los tenía en el disco duro y realmente no sé de que parte de internet los saqué ni quien es su autor, si lo encuentro lo añado.

Un saludo
Sergi

[ジ]

De mucha utilidad _Sergi_ , mira ver si puedes añadir más, salu2

[Robokop]

Gracias Muy buenos y necesarios cuando se requiere trabajar con grandes cantidades de datos

[Kizar]

Base 64 es muy conocido, por ejemplo se usa para codificar los archivos adjuntos k se envia por email.
Me gustaria k explicases cual de los demas k as dicho reduce mas el tamaño de el archivo

[WarGhost]

si es muy interesante

[Hans el Topo]

yo no sabia que el de fibonacci servia pa eso... xD
pensaba que era para cifrar y tal...

[_Sergi_]

El que más me gusta es el método de Huffman, pero no lo he puesto porque creo que ya se ha hablado del tema.

Un saludo