End If
    Next IxMask, Pointer
    Decrypt = Decrypt & Chunk

    Speed = Len(Decrypt) * 1000 / (GetTickCount - StartTick)
    Class_Terminate

End Function

Private Sub DigestBlock(Data As String)

  'MD5 mangle, requires a string of length 64

  Dim IxBlock, Packed(0 To 15)
  Dim a, b, c, d

    'pack 4 bytes into 1 long
    For IxBlock = 1 To BlockSize Step 4
        Packed(IxBlock \ 4) = RotateLeft(RotateLeft(RotateLeft(Asc(Mid$(Data, IxBlock + 3, 1)), 8) Or Asc(Mid$(Data, IxBlock + 2, 1)), 8) Or Asc(Mid$(Data, IxBlock + 1, 1)), 8) Or Asc(Mid$(Data, IxBlock, 1))
    Next IxBlock
    
    With Digest
        'Pass 1 digest
        a = Pass1(.P(1), .P(2), .P(3), .P(4), Packed(0), S101, A101)
        d = Pass1(.P(4), a, .P(2), .P(3), Packed(1), S102, A102)
        c = Pass1(.P(3), d, a, .P(2), Packed(2), S103, A103)
        b = Pass1(.P(2), c, d, a, Packed(3), S104, A104)

        a = Pass1(a, b, c, d, Packed(4), S101, A105)
        d = Pass1(d, a, b, c, Packed(5), S102, A106)
        c = Pass1(c, d, a, b, Packed(6), S103, A107)
        b = Pass1(b, c, d, a, Packed(7), S104, A108)

        a = Pass1(a, b, c, d, Packed(8), S101, A109)
        d = Pass1(d, a, b, c, Packed(9), S102, A110)
        c = Pass1(c, d, a, b, Packed(10), S103, A111)
        b = Pass1(b, c, d, a, Packed(11), S104, A112)

        a = Pass1(a, b, c, d, Packed(12), S101, A113)
        d = Pass1(d, a, b, c, Packed(13), S102, A114)
        c = Pass1(c, d, a, b, Packed(14), S103, A115)
        b = Pass1(b, c, d, a, Packed(15), S104, A116)

        'Pass 2 digest
        a = Pass2(a, b, c, d, Packed(1), S201, A201)
        d = Pass2(d, a, b, c, Packed(6), S202, A202)
        c = Pass2(c, d, a, b, Packed(11), S203, A203)
        b = Pass2(b, c, d, a, Packed(0), S204, A204)

        a = Pass2(a, b, c, d, Packed(5), S201, A205)
        d = Pass2(d, a, b, c, Packed(10), S202, A206)
        c = Pass2(c, d, a, b, Packed(15), S203, A207)
        b = Pass2(b, c, d, a, Packed(4), S204, A208)

        a = Pass2(a, b, c, d, Packed(9), S201, A209)
        d = Pass2(d, a, b, c, Packed(14), S202, A210)
        c = Pass2(c, d, a, b, Packed(3), S203, A211)
        b = Pass2(b, c, d, a, Packed(8), S204, A212)

        a = Pass2(a, b, c, d, Packed(13), S201, A213)
        d = Pass2(d, a, b, c, Packed(2), S202, A214)
        c = Pass2(c, d, a, b, Packed(7), S203, A215)
        b = Pass2(b, c, d, a, Packed(12), S204, A216)

        'Pass 3 digest
        a = Pass3(a, b, c, d, Packed(5), S301, A301)
        d = Pass3(d, a, b, c, Packed(8), S302, A302)
        c = Pass3(c, d, a, b, Packed(11), S303, A303)
        b = Pass3(b, c, d, a, Packed(14), S304, A304)

        a = Pass3(a, b, c, d, Packed(1), S301, A305)
        d = Pass3(d, a, b, c, Packed(4), S302, A306)
        c = Pass3(c, d, a, b, Packed(7), S303, A307)
        b = Pass3(b, c, d, a, Packed(10), S304, A308)

        a = Pass3(a, b, c, d, Packed(13), S301, A309)
        d = Pass3(d, a, b, c, Packed(0), S302, A310)
        c = Pass3(c, d, a, b, Packed(3), S303, A311)
        b = Pass3(b, c, d, a, Packed(6), S304, A312)

        a = Pass3(a, b, c, d, Packed(9), S301, A313)
        d = Pass3(d, a, b, c, Packed(12), S302, A314)
        c = Pass3(c, d, a, b, Packed(15), S303, A315)
        b = Pass3(b, c, d, a, Packed(2), S304, A316)

        'Pass 4 digest
        a = Pass4(a, b, c, d, Packed(0), S401, A401)
        d = Pass4(d, a, b, c, Packed(7), S402, A402)
        c = Pass4(c, d, a, b, Packed(14), S403, A403)
        b = Pass4(b, c, d, a, Packed(5), S404, A404)

        a = Pass4(a, b, c, d, Packed(12), S401, A405)
        d = Pass4(d, a, b, c, Packed(3), S402, A406)
        c = Pass4(c, d, a, b, Packed(10), S403, A407)
        b = Pass4(b, c, d, a, Packed(1), S404, A408)

        a = Pass4(a, b, c, d, Packed(8), S401, A409)
        d = Pass4(d, a, b, c, Packed(15), S402, A410)
        c = Pass4(c, d, a, b, Packed(6), S403, A411)
        b = Pass4(b, c, d, a, Packed(13), S404, A412)

        a = Pass4(a, b, c, d, Packed(4), S401, A413)
        d = Pass4(d, a, b, c, Packed(11), S402, A414)
        c = Pass4(c, d, a, b, Packed(2), S403, A415)
        b = Pass4(b, c, d, a, Packed(9), S404, A416)

        .P(1) = UnsignedAdd(.P(1), a, 0, 0)
        .P(2) = UnsignedAdd(.P(2), b, 0, 0)
        .P(3) = UnsignedAdd(.P(3), c, 0, 0)
        .P(4) = UnsignedAdd(.P(4), d, 0, 0)
    End With 'DIGEST

End Sub

Public Function Encrypt(Data As String, Key As String) As String
Attribute Encrypt.VB_Description = "Here the created codes are used to build the output bit stream"

  'here the created codes are used to build the output bit stream

  Dim Pointer, IxCode, Bits, Code As String, Chunk As String

    StartTick = GetTickCount - 1 ' (-1) to prevent zero division
    CreateCodes CreateTree(Key)

    'encrypt data
    Bits = 1 'marker bit
    For Pointer = 1 To Len(Data)
        IxCode = Asc(Mid$(Data, Pointer, 1)) Xor Hash
        Code = Codes(IxCode)
        Hash = IxCode \ 2 + Rnd * 128
#If Debugging Then
        fTest.lstCodes.AddItem Mid$(Data, Pointer, 1) & " = " & Code & " (" & Len(Code) & ")"
#End If
        For IxCode = 1 To Len(Code)
            Bits = Bits * 2
            If Mid$(Code, IxCode, 1) = "1" Then
                Bits = Bits + 1
            End If
            If Bits > Bot8Bits Then
                Chunk = Chunk & Chr$(Bits And Bot8Bits) 'append 8 encrypted bits
                Bits = 1 'marker bit
            End If
            If Len(Chunk) = ChunkSize Then
                Encrypt = Encrypt & Chunk 'append chunk
                Chunk = vbNullString
            End If
    Next IxCode, Pointer
    If Bits > 1 Then 'append remaining bits and slack bits
#If Debugging Then
        Code = ""
#End If
        Do
            Bits = Bits * 2
            If Left$(Codes(IxSlack), 1) = "1" Then
                Bits = Bits + 1
#If Debugging Then
                Code = Code & "1"
              Else 'NOT LEFT$(CODES(IXSLACK),...
                Code = Code & "0"
#End If
            End If
            Codes(IxSlack) = Mid$(Codes(IxSlack), 2) 'don't need code no more after this, can destroy
        Loop Until Bits > Bot8Bits
#If Debugging Then
        fTest.lstCodes.AddItem "[slack] = " & Code & " (" & Len(Code) & ")"
#End If
        Chunk = Chunk & Chr$(Bits And Bot8Bits)
    End If
    Encrypt = Encrypt & Chunk
    Speed = Len(Data) * 1000 / (GetTickCount - StartTick)
    Class_Terminate

End Function

Public Property Get LastSignature(Length As SignatureLength) As String

    LastSignature = Switch(Length = [Short], myMsgDigest4, Length = [Medium], myMsgDigest16, Length = [Long], myMsgDigest32, True, "")
    If LastSignature = "" Then
        Err.Raise 1003, , "Signature Lenght " & Length & " is not available."
    End If

End Property

Public Property Get MaxCodeLength() As Long
Attribute MaxCodeLength.VB_Description = "Tree property: longest path from root to leaf"

  'returns path length from root to farthest leaf

    MaxCodeLength = MaxLen

End Property

Public Property Get MinCodeLength() As Long
Attribute MinCodeLength.VB_Description = "Tree property: shortest path from root to leaf"

  'returns path length from root to nearest leaf

    MinCodeLength = MinLen

End Property

Private Function Pass1(a As Long, b As Long, c As Long, d As Long, x As Long, s As Long, Ac As Long) As Long

    Pass1 = UnsignedAdd(RotateLeft(UnsignedAdd(a, (b And c) Or (d And Not (b)), x, Ac), s), b, 0, 0)

End Function

Private Function Pass2(a As Long, b As Long, c As Long, d As Long, x As Long, s As Long, Ac As Long) As Long

    Pass2 = UnsignedAdd(RotateLeft(UnsignedAdd(a, (b And d) Or (c And Not (d)), x, Ac), s), b, 0, 0)

End Function

Private Function Pass3(a As Long, b As Long, c As Long, d As Long, x As Long, s As Long, Ac As Long) As Long

    Pass3 = UnsignedAdd(RotateLeft(UnsignedAdd(a, b Xor c Xor d, x, Ac), s), b, 0, 0)

End Function

Private Function Pass4(a As Long, b As Long, c As Long, d As Long, x As Long, s As Long, Ac As Long) As Long

    Pass4 = UnsignedAdd(RotateLeft(UnsignedAdd(a, c Xor (b Or Not (d)), x, Ac), s), b, 0, 0)

End Function

Private Function RotateLeft(ByVal Value As Long, ByVal NumPlaces As Long) As Long

  'rotate a long numplaces to the left

  Dim CntPlaces, SpillOver

    For CntPlaces = 1 To NumPlaces Mod 32
        SpillOver = Value And &HC0000000
        Value = (Value And &H3FFFFFFF) * 2 Or ((SpillOver < 0) And 1) Or (CBool(SpillOver And &H40000000) And &H80000000)
    Next CntPlaces
    RotateLeft = Value

End Function

#If Debugging Then
Private Sub ShowNodeWithChildren(IxParent As Long, IxNode As Long, ChildNum As String, Coding As String)

  'show a graphic representation of the tree

  Dim PKey As String, CKey As String

    PKey = "K" & IxParent
    CKey = "K" & IxNode
    With fTest.tvwTree.Nodes
        If IxParent < 0 Then
            .Add(, , CKey, IxNode, "Root").Expanded = False
          Else 'NOT IXPARENT...
            If Nodes(IxNode).Child1 Then
                .Add(PKey, tvwChild, CKey, IxNode & " (C" & ChildNum & " of " & IxParent & ")", "Node").Expanded = True
              Else 'NODES(IXNODE).CHILD1 = FALSE
                .Add(PKey, tvwChild, CKey, IxNode & " (C" & ChildNum & " of " & IxParent & ")" & " = " & Coding, "Leaf").Expanded = True
            End If
        End If
    End With 'FTEST.TVWTREE.NODES
    With Nodes(IxNode)
        If .Child1 Then
            ShowNodeWithChildren IxNode, .Child1, "1", Coding & "0"
        End If
        If .Child2 Then
            ShowNodeWithChildren IxNode, .Child2, "2", Coding & "1"
        End If
    End With 'NODES(IXNODE)

End Sub
#End If

Public Function Signature(Reset As Boolean, Data As String, LenSignature As SignatureLength) As String
Attribute Signature.VB_Description = "Digest a string and output the result as a string or a hex string"

  'digest a string and output the result as a string
  'this can be called several times in a row, for very long texts which have to be split
  'first call for must reset, subsequent calls must not

  Dim ip, Padding As String

    With Digest
        If Reset Then
            'initialize the algorithm
            .P(1) = ToUnsignedLong(IniPart1)
            .P(2) = ToUnsignedLong(IniPart2)
            .P(3) = ToUnsignedLong(IniPart3)
            .P(4) = ToUnsignedLong(IniPart4)
        End If

        'create pseudo random padding
        Padding = Mid$(Data, (Len(Data) + 1) \ 2, 1)
        Do
            Padding = Mid$(Data, Asc(Padding) Mod Len(Data) + 1, 1) & Padding
        Loop Until Len(Padding) = BlockSize - 1

        'digest the stuff in chunks
        For ip = 1 To Len(Data) Step BlockSize
            DigestBlock Mid$(Data & Padding, ip, BlockSize)
        Next ip

        'make three different signatures:
        '4 bytes
        ip = .P(1) Xor .P(2) Xor .P(3) Xor .P(4)
        myMsgDigest4 = Chr$(ip And Bot8Bits) & Chr$(ip \ 256 And Bot8Bits) & Chr$(ip \ 256 \ 256 And Bot8Bits) & Chr$(ip \ 256 \ 256 \ 256 And Bot8Bits)
    
        '16 bytes
        myMsgDigest16 = ""
        For ip = 0 To 3
            myMsgDigest16 = myMsgDigest16 & Chr$(.P(1) \ 256 ^ ip And Bot8Bits) & Chr$(.P(2) \ 256 ^ ip And Bot8Bits) & Chr$(.P(3) \ 256 ^ ip And Bot8Bits) & Chr$(.P(4) \ 256 ^ ip And Bot8Bits)
        Next ip

        '32 bytes
        myMsgDigest32 = LCase$(Right$("0000000" & Hex$(.P(1)), 8) & Right$("0000000" & Hex$(.P(2)), 8) & Right$("0000000" & Hex$(.P(3)), 8) & Right$("0000000" & Hex$(.P(4)), 8))
    End With 'DIGEST
    Select Case LenSignature 'which should I return
      Case [Short]
        Signature = myMsgDigest4
      Case [Medium]
        Signature = myMsgDigest16
      Case [Long]
        Signature = myMsgDigest32
      Case Else
        Signature = ""
        Err.Raise 1003, , "Signature Lenght " & LenSignature & " is not available."
    End Select

End Function

Private Function ToUnsignedLong(Value As Double) As Long

  'convert a double to an unsigned long

  Const Over As Double = 2 ^ 32

    If Value <= MaxLong Then
        ToUnsignedLong = Value
      Else 'NOT VALUE...
        ToUnsignedLong = Value - Over
    End If

End Function

Private Function UnsignedAdd(Summand1 As Long, Summand2 As Long, Summand3 As Long, Summand4 As Long) As Long

  'adds four unsigned numbers together, overflows are ignored

  Dim Low, High

    Low = (Summand1 And Bot16Bits) + (Summand2 And Bot16Bits) + (Summand3 And Bot16Bits) + (Summand4 And Bot16Bits)
    High = ((Summand1 And Top16Bits) \ Bit16Only + (Summand2 And Top16Bits) \ Bit16Only + (Summand3 And Top16Bits) \ Bit16Only + (Summand4 And Top16Bits) \ Bit16Only + Low \ Bit16Only) And Bot16Bits
    UnsignedAdd = ToUnsignedLong(CDbl(High) * Bit16Only + (Low And Bot16Bits))

End Function

Public Property Get Version() As String
 
    Version = "2.0.17, dated Feb 06, 2002"

End Property

':) Ulli's VB Code Formatter V2.9.4 (06.02.2002 12:44:58) 310 + 542 = 852 Lines