comp_groupsmart.bas

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

Attribute VB_Name = "Comp_GroupSmart"


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