comp_groupsmart2.bas

20多种VB软件的加密与压缩模块

Attribute VB_Name = "Comp_GroupSmart2"


Option Explicit

'This is a 1 run method but we have to keep the whole contents
'in memory until some variables are saved wich are needed bij the decompressor

Private ExtraLengthBits(31) As Integer
Private StartValLength(31) As Long

Private Type BytePos
    Data() As Byte
    Position As Long
    Buffer As Integer
    BitPos As Integer
End Type
Private Stream(3) As BytePos    '0=control   1=length  2=LowestValue  3=compressed

Private Type Grouping
    LowValue As Long
    HighValue As Long
    NumInGroup As Long
End Type
   
Private Sub Init_Grouping2()
'                            Distance Codes
'                            --------------
'      Extra           Extra             Extra               Extra
' Code Bits Dist  Code Bits  Dist   Code Bits Distance  Code Bits Distance
' ---- ---- ----  ---- ---- ------  ---- ---- --------  ---- ---- --------
'   0   0    1      8   3   17-24    16    7  257-384    24   11  4097-6144
'   1   0    2      9   3   25-32    17    7  385-512    25   11  6145-8192
'   2   0    3     10   4   33-48    18    8  513-768    26   12  8193-12288
'   3   0    4     11   4   49-64    19    8  769-1024   27   12 12289-16384
'   4   1   5,6    12   5   65-96    20    9 1025-1536   28   13 16385-24576
'   5   1   7,8    13   5   97-128   21    9 1537-2048   29   13 24577-32767
'   6   2   9-12   14   6  129-192   22   10 2049-3072   30   14 32768-49151
'   7   2  13-16   15   6  193-256   23   10 3073-4096   31   14 49152-65535
    
    Dim NuVal As Long
    Dim BitTel As Integer
    Dim Nubits As Integer
    Dim StartBitTel As Boolean
    Dim X As Integer
    ExtraLengthBits(0) = 0: StartValLength(0) = 0
    ExtraLengthBits(1) = 0: StartValLength(1) = 1
    NuVal = 2
    Nubits = 0
    BitTel = 0
    For X = 2 To 31
        If BitTel = 2 Then Nubits = Nubits + 1: BitTel = 0
        ExtraLengthBits(X) = Nubits
        StartValLength(X) = NuVal
        NuVal = NuVal + 2 ^ Nubits
        BitTel = BitTel + 1
    Next
    For X = 0 To 3
        ReDim Stream(X).Data(500)
        Stream(X).Position = 0
        Stream(X).BitPos = 0
        Stream(X).Buffer = 0
    Next
End Sub

Public Sub Compress_SmartGrouping2(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 Y As Long
    Dim TotFileLen As Long          'total file len
    Dim Group(1 To 8) As Grouping
    TotFileLen = UBound(ByteArray)
    ReDim OutStream(TotFileLen + (TotFileLen / 7))  'in het slechtste geval
    BeginGroup = 0
'whe start by setting the beginvalues
    Call Init_Grouping2
'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 nor 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 = CheckForBetterWithin2(ByteArray, Group, BestGroup, BeginGroup)
        Do While BestGroup <> NewBest
'yes there is, lets check again to be shure
            BestGroup = NewBest
            NewBest = CheckForBetterWithin2(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 AddGroupCodeToStream2(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 AddLowValueToStream(Group(BestGroup).LowValue)
        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 AddLiteralCodeToStream(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 AddGroupCodeToStream2(0, 0)
'maybe we have some bits leftover so lets store them
    For X = 0 To 3
        Do While Stream(X).BitPos > 0
            Call AddBitsToStream(Stream(X), 0, 1)
        Loop
    Next
    For X = 0 To 3
        If Stream(X).Position > 0 Then
            ReDim Preserve Stream(X).Data(Stream(X).Position - 1)
        Else
            ReDim Stream(X).Data(0)
        End If
    Next
    
    
'totaal benodigde ruimte berekenen en instellen
    TotFileLen = 0
    For X = 0 To 3
        TotFileLen = TotFileLen + UBound(Stream(X).Data) + 1
    Next
    ReDim ByteArray(TotFileLen - 1 + 9)
    
'kopieren naar de uiteindelijke array
    TotFileLen = 0
    For X = 0 To 2
        ByteArray(TotFileLen) = Int((UBound(Stream(X).Data) + 1) / &H10000) And &HFF
        TotFileLen = TotFileLen + 1
        ByteArray(TotFileLen) = Int((UBound(Stream(X).Data) + 1) / &H100) And &HFF
        TotFileLen = TotFileLen + 1
        ByteArray(TotFileLen) = (UBound(Stream(X).Data) + 1) And &HFF
        TotFileLen = TotFileLen + 1
    Next
    For X = 0 To 3
        For Y = 0 To UBound(Stream(X).Data)
            ByteArray(TotFileLen) = Stream(X).Data(Y)
            TotFileLen = TotFileLen + 1
        Next
    Next
End Sub

Private Sub AddGroupCodeToStream2(Number As Long, GroupNum As Integer)
    Dim NumVal As Long
'Store 3 bits to say what grouping method is used
    Call AddBitsToStream(Stream(0), CLng(GroupNum), 3)
'store the length of the groep
    NumVal = GetExtraBits(Number)
    Call AddBitsToStream(Stream(1), NumVal, 5)
    Call AddBitsToStream(Stream(1), Number, CLng(ExtraLengthBits(NumVal)))
End Sub

Private Function GetExtraBits(Number As Long) As Long
'store the length of the groep
    Dim Y As Long
    For Y = 0 To 31
        If StartValLength(Y) + 2 ^ ExtraLengthBits(Y) > Number Then
            Exit For
        End If
    Next
    GetExtraBits = Y
End Function

Private Sub AddLowValueToStream(Number As Long)
    Call AddBitsToStream(Stream(2), Number, 8)
End Sub

Private Sub AddLiteralCodeToStream(Number As Long, Numbits As Integer)
    Call AddBitsToStream(Stream(3), Number, Numbits)
End Sub

'this sub will add an amount of bits to a sertain stream
Private Sub AddBitsToStream(Toarray As BytePos, Number As Long, Numbits As Integer)
    Dim X As Long
    If Numbits = 8 And Toarray.BitPos = 0 Then
        If Toarray.Position > UBound(Toarray.Data) Then ReDim Preserve Toarray.Data(Toarray.Position + 500)
        Toarray.Data(Toarray.Position) = Number And &HFF
        Toarray.Position = Toarray.Position + 1
        Exit Sub
    End If
    For X = Numbits - 1 To 0 Step -1
        Toarray.Buffer = Toarray.Buffer * 2 + (-1 * ((Number And 2 ^ X) > 0))
        Toarray.BitPos = Toarray.BitPos + 1
        If Toarray.BitPos = 8 Then
            If Toarray.Position > UBound(Toarray.Data) Then ReDim Preserve Toarray.Data(Toarray.Position + 500)
            Toarray.Data(Toarray.Position) = Toarray.Buffer
            Toarray.BitPos = 0
            Toarray.Buffer = 0
            Toarray.Position = Toarray.Position + 1
        End If
    Next
End Sub

'This is Smart part of the grouping method
'it will look for the way to get the best compression
Private Function CheckForBetterWithin2(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