comp_huffshort16chars.bas

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

    Dim DictString As String
    Dim Waarde As Long
'eerst gaan we kijken of dit wel een goede file is
    If FileArray(0) <> ASC("H") Or FileArray(1) <> ASC("E") Then
        MsgBox "This is not a Huffman Compressed file"
        Exit Sub
    End If
    If FileArray(2) = ASC("0") Then 'wel huffman maar niet gecomprimeerd
        Call CopyMem(FileArray(0), FileArray(3), UBound(FileArray) - 3)
        ReDim Preserve FileArray(UBound(FileArray) - 3)
'        ReDim DeCompressed(UBound(FileArray) - 3)
'        For X = 3 To UBound(FileArray)
'            DeCompressed(X - 3) = FileArray(X)
'        Next
        Exit Sub
    End If
    If FileArray(2) <> ASC("4") Then 'niet gecomprimeerd met deze compressor
        MsgBox "file corrupt or no Huffman compression"
        Exit Sub
    End If
    InpPos = 3
'dictionary inlezen en er een bitsequence van maken
    For X = 0 To 7
        BitValue(X) = 2 ^ X
    Next
    TotBits = GetAscCodeFromArray(FileArray, InpPos)
    DictString = DictString & Chr(TotBits)
    TelBits = 0
    For X = 1 To TotBits
        ByteValue = GetAscCodeFromArray(FileArray, InpPos)
        TelBits = TelBits + ByteValue
        DictString = DictString & Chr(ByteValue)
    Next
    For X = 1 To TelBits
        DictString = DictString & Chr(GetAscCodeFromArray(FileArray, InpPos))
    Next
    Call Create_Huffcodes(DictString, False)
    
'nugaan we de checksum lezen
    CheckSum = GetAscCodeFromArray(FileArray, InpPos)
'nu gaan we de originele lengte lezen
    Char = GetAscCodeFromArray(FileArray, InpPos)
    Do While Char <> ASC(vbCr)
        OrgLen = OrgLen & Chr(Char)
        Char = GetAscCodeFromArray(FileArray, InpPos)
    Loop
'nu gaan we de overige bytes decomprimeren
    ReDim DeCompressed(OrgLen - 1)
    Nulen = 0
    NuNode = 0
    StringBuffer = ""
    TelBits = 7
    Waarde = 0
    TotBits = 0
    ReadByte = 0
    Do While Nulen < OrgLen
        If TelBits = -1 Then
            InpPos = InpPos + 1
            TelBits = 7
        End If
        Waarde = Waarde * 2
        TotBits = TotBits + 1
        If (FileArray(InpPos) And 2 ^ TelBits) > 0 Then
            Waarde = Waarde + 1
        End If
        If TotBits = 20 Then
            Err.Raise vbError, "DecompressHuffman", "We zijn de boom tot op een dood punt genaderd, waarschijnlijk is de header beschadigd"
            Exit Sub
        End If
        If BitVal(Waarde) = TotBits Then              'gevonden
            If ReadByte = 0 Then
                CalcByte = CharVal(Waarde) * 16
            Else
                CalcByte = CalcByte + CharVal(Waarde)
            End If
            ReadByte = ReadByte + 1
            Waarde = 0
            TotBits = 0
            If ReadByte = 2 Then
                DeCompressed(Nulen) = CalcByte
                TestSum = TestSum Xor DeCompressed(Nulen)
                Nulen = Nulen + 1
                ReadByte = 0
            End If
        End If
        TelBits = TelBits - 1
    Loop
    If CheckSum <> TestSum Then
        Err.Raise vbError, "Decompresshuffman", "Checksum is incorrect"
        Exit Sub
    End If
    ReDim FileArray(OrgLen - 1)
    Call CopyMem(FileArray(0), DeCompressed(0), OrgLen)
    Exit Sub
    
Create_New_Node:
    NumberOfNodes = NumberOfNodes + 1
    TreeNodes(NumberOfNodes, 0) = -1
    TreeNodes(NumberOfNodes, 1) = -1
    TreeNodes(NumberOfNodes, 2) = -1
    TreeNodes(NumberOfNodes, 3) = NuNode
    TreeNodes(NumberOfNodes, 4) = -1
    ToNode = NumberOfNodes
    Return
End Sub

Private Function BinToDec(Binair As String) As Integer
    Dim X As Integer
    If Len(Binair) > 8 Then
        Err.Raise vbError, "BinToDec", "This binary number dont fit in 1 byte"
        Exit Function
    End If
    Do While Len(Binair) <> 8
        Binair = Binair & "0"
    Loop
    For X = 1 To 8
        BinToDec = BinToDec + (Mid(Binair, X, 1) * 2 ^ (8 - X))
    Next
End Function

Private Function DecToBin(Waarde As Integer) As String
    Dim X As Integer
    For X = 7 To 0 Step -1
        DecToBin = DecToBin & CStr(Abs((Waarde And (2 ^ X)) > 0))
    Next
End Function

Private Sub AddASC2Array(WichArray() As Byte, StartPos As Long, Text As String)
    Dim X As Long
    For X = 1 To Len(Text)
        WichArray(StartPos + X) = ASC(Mid(Text, X, 1))
    Next
    StartPos = StartPos + Len(Text)
End Sub

Private Function GetAscCodeFromArray(WichArray() As Byte, StartPos As Long) As Integer
    GetAscCodeFromArray = WichArray(StartPos)
    StartPos = StartPos + 1
End Function

Private Sub AddHEX2Array(WichArray() As Byte, StartPos As Long, Waarde As Long, TotBytes As Integer)
    Dim HexWaarde As String
    Dim X As Long
    HexWaarde = Right(String(2 * TotBytes, "0") & Hex(Waarde), 2 * TotBytes)
    For X = 1 To TotBytes
        WichArray(StartPos + X) = "&h" & Mid(HexWaarde, (X - 1) * 2 + 1, 2)
    Next
    StartPos = StartPos + TotBytes
End Sub

Private Function GetHexValFromArray(WichArray() As Byte, StartPos As Long, TotBytes As Integer) As Long
    Dim X As Long
    Dim TempHex As String
    For X = 0 To TotBytes - 1
        TempHex = TempHex & Right("00" & Hex(WichArray(StartPos + X)), 2)
    Next
    StartPos = StartPos + TotBytes
    GetHexValFromArray = "&h" & TempHex
End Function

Private Sub Create_Huffcodes(DictString As String, ForCompress As Boolean)
    Dim Code As Long
    Dim TotKars As Integer
    Dim TotLengs As Integer
    Dim ReadPos As Integer
    Dim bl_count() As Integer
    Dim TreeLang() As Integer
    Dim MaxLang As Integer
    Dim TreeCode() As Long
    Dim next_code() As Long
    Dim Chars() As Integer
'    Dim Bits As Integer
    Dim BitString As String
    Dim BitLen As Integer
    Dim Numbits As Integer
    Dim MaxBits As Integer
    Dim maxcode As Long
    Dim N As Integer
    Dim X As Integer
    Dim Y As Integer
    Dim Lang As Integer
'    Call Create_Bytes2
    MaxBits = ASC(Mid(DictString, 1, 1))
    ReDim Preserve bl_count(MaxBits)
    ReadPos = 2
    MaxLang = -1
    For X = 1 To MaxBits
        Numbits = ASC(Mid(DictString, ReadPos, 1))
        If Numbits > 0 Then
            BitLen = X
            bl_count(BitLen) = Numbits
            ReDim Preserve TreeLang(MaxLang + Numbits)
            For Y = 1 To Numbits
                MaxLang = MaxLang + 1
                TreeLang(MaxLang) = BitLen
            Next
        End If
        ReadPos = ReadPos + 1
    Next
    ReDim TreeCode(MaxLang)
    ReDim next_code(MaxBits)
    ReDim Chars(MaxLang)
    For X = 0 To MaxLang
        Chars(X) = ASC(Mid(DictString, ReadPos, 1))
        ReadPos = ReadPos + 1
    Next
    maxcode = 0
    Code = 0
    For N = 1 To MaxBits
        Code = (Code + bl_count(N - 1)) * 2
        next_code(N) = Code
    Next
    For N = 0 To MaxLang
        Lang = TreeLang(N)
        TreeCode(N) = next_code(Lang)
        next_code(Lang) = next_code(Lang) + 1
        If maxcode < next_code(Lang) Then maxcode = next_code(Lang)
    Next
    If ForCompress = True Then
        ReDim BitVal(255)
        ReDim CharVal(255)
        For X = 0 To MaxLang
            BitVal(Chars(X)) = TreeCode(X)
            CharVal(Chars(X)) = TreeLang(X)
'Debug.Print Chars(X); " "; DecToBin1(CLng(TreeCode(X)), CLng(TreeLang(X)))
        Next
    Else
        ReDim BitVal(maxcode)
        ReDim CharVal(maxcode)
        For X = 0 To MaxLang
            BitVal(TreeCode(X)) = TreeLang(X)
            CharVal(TreeCode(X)) = Chars(X)
        Next
    End If
    
End Sub