comp_huffshort16chars.bas

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

Attribute VB_Name = "Comp_HuffShort16Chars"


Option Explicit

'This is a 2 run method

Private BitVal() As Long
Private CharVal() As Long

Public Sub Compress_HuffShort16chars(FileArray() As Byte)
    Dim X As Long
    Dim Y As Long
    Dim Z As Long
    Dim Char As Integer
    Dim BitLen As Integer
    Dim FileLen As Long
    Dim TelBits As Long
    Dim TotBits As Long
    Dim OutStream() As Byte
    Dim TreeNodes(511, 4) As Long
    Dim BitValue(7) As Byte
    Dim ByteValue As Byte
    Dim ByteBuff As String
    Dim CalcByte As Byte
    Dim CheckSum As Integer
    Dim NumberOfNodes As Integer
    Dim OrgNumberOfNodes As Integer
    Dim PackedSize As Long
    Dim DictSize As Long
    Dim OutPutSize As Long
    Dim CharCount(16) As Long
    Dim Bits(255) As String
    Dim Nubits As String
    Dim TempBits As String
    Dim lTemp As Long
    Dim lWeight As Long
    Dim rWeight As Long
    Dim MaxWeight As Long
    Dim NowWeight As Long
    Dim lNode As Integer
    Dim rNode As Integer
    Dim StringBuffer As String
    Dim BitLens(16) As Integer
    Dim CharLens(16) As String
    Dim DictString As String
    FileLen = UBound(FileArray)
    OutPutSize = -1
    If (FileLen = 0) Then
        ReDim Preserve FileArray(2)
        FileArray(0) = 72 'H
        FileArray(1) = 69 'E
        FileArray(2) = 48 '0
        Exit Sub
    End If
'treenodes(,0)=weight
'treenodes(,1)=Character
'treenodes(,2)=LeftNode
'treenodes(,3)=RightNode
'treenodes(,4)=ParentNode
'eerst gaan we de input doorlezen op zoek naar het meest voorkomende karakter
'en laten we dan ook gelijk de checksum maar doen
    For X = 0 To UBound(FileArray)
        CharCount((FileArray(X) And &HF0) / 16) = CharCount((FileArray(X) And &HF0) / 16) + 1
        CharCount(FileArray(X) And &HF) = CharCount(FileArray(X) And &HF) + 1
        CheckSum = CheckSum Xor FileArray(X)
    Next
'nu gaan we diegene die 0 maal voorkomen verwijderen
'en gelijk maar de blaadjes aanmaken
    MaxWeight = (UBound(FileArray) + 1) * 2
    Z = -1
    For X = 0 To 16
        If CharCount(X) <> 0 Then
            Z = Z + 1
            TreeNodes(Z, 0) = CharCount(X)
            TreeNodes(Z, 1) = X
            TreeNodes(Z, 2) = -1    'leftnode
            TreeNodes(Z, 3) = -1    'rightnode
            TreeNodes(Z, 4) = -1    'parentnode
        End If
    Next
    NumberOfNodes = Z
'nu gaan we de boom samenstallen (blaadjes verbinden met de stam)
    OrgNumberOfNodes = NumberOfNodes
    For X = NumberOfNodes + 1 To 2 Step -1
        lWeight = MaxWeight * 2: rWeight = MaxWeight * 2
        For Y = 0 To NumberOfNodes + 1
            If TreeNodes(Y, 4) = -1 Then
                NowWeight = TreeNodes(Y, 0)
                If NowWeight < rWeight Or NowWeight < lWeight Then
                    If rWeight > lWeight Then
                        rWeight = NowWeight
                        rNode = Y
                    Else
                        lWeight = NowWeight
                        lNode = Y
                    End If
                End If
            End If
        Next Y
        NumberOfNodes = NumberOfNodes + 1
        TreeNodes(lNode, 4) = NumberOfNodes
        TreeNodes(rNode, 4) = NumberOfNodes
        TreeNodes(NumberOfNodes, 0) = lWeight + rWeight
        TreeNodes(NumberOfNodes, 1) = -1
        TreeNodes(NumberOfNodes, 2) = lNode
        TreeNodes(NumberOfNodes, 3) = rNode
        TreeNodes(NumberOfNodes, 4) = -1
    Next
'nu gaan we de bitsequence bepalen
'en tegelijk gaan we bereken hoe lang de gecodeerde file wordt
'en hoe groot of dat de dictionary wordt
    TotBits = 0
    For X = 0 To OrgNumberOfNodes
        Char = TreeNodes(X, 1)
        Y = X
        Z = Y
        BitLen = 0
        Do While TreeNodes(Y, 4) <> -1
            Y = TreeNodes(Y, 4)
            If TreeNodes(Y, 2) = Z Or TreeNodes(Y, 3) = Z Then
                BitLen = BitLen + 1
            Else
                MsgBox "error creating bitpatern"
                Exit Sub
            End If
            Z = Y
        Loop
        If TotBits < BitLen Then TotBits = BitLen
        BitLens(BitLen) = BitLens(BitLen) + 1
        CharLens(BitLen) = CharLens(BitLen) & Chr(Char)
        PackedSize = PackedSize + (TreeNodes(X, 0) * BitLen)
        DictSize = DictSize + 2
    Next
    PackedSize = Int(PackedSize / 8) + Abs(1 * ((PackedSize / 8) - Int(PackedSize / 8) > 0))
    DictString = Chr(TotBits)
    For X = 1 To TotBits
        DictString = DictString & Chr(BitLens(X))
    Next
    For X = 1 To TotBits
        DictString = DictString + CharLens(X)
'        Debug.Print X; " "; BitLens(X); " "; Len(CharLens(X))
    Next
    Call Create_Huffcodes(DictString, True)
'even kijken of de totale lengte van de gecomprimeerde file kleiner is dan het origineel
'en zo nee, dan de ongecomprimeerde file voorzien van header terugsturen
'    If 3 + Len(DictString) + 1 + Len(CStr(UBound(FileArray))) + 1 + PackedSize > UBound(FileArray) Then
'        ReDim Preserve FileArray(UBound(FileArray) + 3)
'        Call CopyMem(FileArray(3), FileArray(0), FileLen + 1)
'        FileArray(0) = 72
'        FileArray(1) = 69
'        FileArray(2) = 48
'        FileArray(3) = 13
'        Exit Sub
'    End If
    ReDim OutStream(3 + Len(DictString) + 1 + Len(CStr(UBound(FileArray))) + 1 + PackedSize)
'de data wordt inderdaad kleiner dus gaan we maar de header in elkaar zetten
'output as HE4 want dit is niet de standaard indeling van een huffman encoded file
    For X = 0 To 7
        BitValue(X) = 2 ^ X
    Next

'opbouw van het gecomprimeerde bestand is
'ID van de file = 3 bytes in ASC
'grootte van de dictionary = 2 bytes in HEX
'de dictionary in ASC
'   1e = ascii code
'   2e = bitcount
'   3e = bitsequence    :kan ook 4e en 5e worden
'de checksum van de te comprimeren file = 1 byte in asc
'de originele grootte van de te comprimeren file + vbcr
'de gecomprimeerde file
    Call AddASC2Array(OutStream, OutPutSize, "HE4")
    Call AddASC2Array(OutStream, OutPutSize, DictString)
    Call AddASC2Array(OutStream, OutPutSize, Chr(CheckSum))
    Call AddASC2Array(OutStream, OutPutSize, CStr(UBound(FileArray) + 1) & vbCr)
'nu gaan we de eigenlijke data coderen aan de hand van de dictionary
'GoTo einde
    TelBits = 7
    ByteValue = 0
    For X = 0 To UBound(FileArray)
        For Z = 1 To 2
            If Z = 1 Then
                CalcByte = (FileArray(X) And &HF0) / 16
            Else
                CalcByte = FileArray(X) And &HF
            End If
            For Y = CharVal(CalcByte) - 1 To 0 Step -1 'bitlengte
                If (BitVal(CalcByte) And 2 ^ Y) > 0 Then
                    ByteValue = ByteValue + BitValue(TelBits)
                End If
                TelBits = TelBits - 1
                If TelBits = -1 Then
                    OutPutSize = OutPutSize + 1
                    OutStream(OutPutSize) = ByteValue
                    TelBits = 7
                    ByteValue = 0
                End If
            Next
        Next
    Next
    If TelBits <> 7 Then
        OutPutSize = OutPutSize + 1
        OutStream(OutPutSize) = ByteValue
    End If
Einde:
    ReDim Preserve OutStream(OutPutSize)
    ReDim FileArray(OutPutSize)
    Call CopyMem(FileArray(0), OutStream(0), OutPutSize + 1)
    
End Sub

Public Sub Decompress_HuffShort16chars(FileArray() As Byte)
    Dim X As Long
    Dim Y As Long
    Dim Z As Long
    Dim TreeNodes(511, 4) As Long
    Dim DeCompressed() As Byte
    Dim Leaf(255, 1) As Byte
    Dim ByteValue As Byte
    Dim ReadByte As Integer
    Dim CalcByte As Byte
    Dim BitValue(7) As Byte
    Dim NumberOfNodes As Integer
    Dim CheckSum As Byte
    Dim TestSum As Byte
    Dim NuNode As Integer
    Dim ToNode As Integer
    Dim Char As Byte
    Dim BitLen As Byte
    Dim Bits(255) As String
    Dim TempBits As String
    Dim StringBuffer As String
    Dim TotBits As Long
    Dim TelBits As Integer
    Dim DictSize As Long
    Dim InpPos As Long
    Dim OrgLen As Long
    Dim Nulen As Long