comp_huffshortdict.bas

包含几十个加密解密类和压缩解压缩类,DES,LZW,Huffman

Attribute VB_Name = "Comp_HuffShortDict"

' **********************************************************************
'  描  述：21种加密54种压缩 算法模块 海阔天空收集整理
'  Play78.com : 网站导航，源码之家，绝对开源
'  海阔天空整理,有问题请上www.paly78.com 提
'  网址：http://www.play78.com/
'  QQ：13355575
'  e-mail:[e-mail]
' **********************************************************************
Option Explicit

'This is a 2 run method

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

Public Sub Compress_HuffManShortDict(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 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(255) 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)) = CharCount(FileArray(X)) + 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
    Z = -1
    For X = 0 To 255
        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
        If BitLens(X) = 256 Then
            MsgBox "This code can't be compressed using this scheme"
            Exit Sub
        End If
        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 Y = CharVal(FileArray(X)) - 1 To 0 Step -1 'bitlengte
            If (BitVal(FileArray(X)) 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
    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_HuffmanShortDict(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 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