VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cEncDec"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
DefLng A-Z 'we're 32 bit!

#Const Debugging = True 'Set to False for final compilation

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'for variable length encryption

Private Type TreeNode   'the tree nodes
    Weight              As Long
    Parent              As Long
    Child1              As Long
    Child2              As Long
End Type

Private Nodes()         As TreeNode     'the tree
Attribute Nodes.VB_VarDescription = "The Tree"
Private Codes()         As String       'the variable lenght codes
Attribute Codes.VB_VarDescription = "The variable lenght Codes"
Private Masks(0 To 7)   As Long
Attribute Masks.VB_VarDescription = "Bit masks used during decrypting"
Private Hash            As Long
Attribute Hash.VB_VarDescription = "Password and text digest"
Private IxSlack         As Long         'index pointing to code to be used as slack
Attribute IxSlack.VB_VarDescription = "Index pointing to a suitable caditate to fill slack bits"
Private MinLen          As Long         'tree properties
Attribute MinLen.VB_VarDescription = "local property"
Private MaxLen          As Long
Attribute MaxLen.VB_VarDescription = "local property"
Private Speed           As Long         'conversion speed
Attribute Speed.VB_VarDescription = "Conversion speed"

Private Declare Function GetTickCount Lib "kernel32" () As Long
Private StartTick       As Long
Attribute StartTick.VB_VarDescription = "From GetTickCount"

Private Const MaxLong   As Long = 2 ^ 31 - 1
Attribute MaxLong.VB_VarDescription = "2 ^ 31 - 1"
Private Const ChunkSize As Long = 255
Attribute ChunkSize.VB_VarDescription = "Chunksize is used during encryption and decryption"

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'for MD5 message digest

Private Const IniPart1  As Double = 1732584193#
Private Const IniPart2  As Double = 4023233417#
Private Const IniPart3  As Double = 2562383102#
Private Const IniPart4  As Double = 271733878#

'Pass 1
Private Const S101      As Long = 7
Private Const S102      As Long = 12
Private Const S103      As Long = 17
Private Const S104      As Long = 22
Private Const A101      As Long = -680876936
Private Const A102      As Long = -389564586
Private Const A103      As Long = 606105819
Private Const A104      As Long = -1044525330
Private Const A105      As Long = -176418897
Private Const A106      As Long = 1200080426
Private Const A107      As Long = -1473231341
Private Const A108      As Long = -45705983
Private Const A109      As Long = 1770035416
Private Const A110      As Long = -1958414417
Private Const A111      As Long = -42063
Private Const A112      As Long = -1990404162
Private Const A113      As Long = 1804603682
Private Const A114      As Long = -40341101
Private Const A115      As Long = -1502002290
Private Const A116      As Long = 1236535329

'Pass 2
Private Const S201      As Long = 5
Private Const S202      As Long = 9
Private Const S203      As Long = 14
Private Const S204      As Long = 20
Private Const A201      As Long = -165796510
Private Const A202      As Long = -1069501632
Private Const A203      As Long = 643717713
Private Const A204      As Long = -373897302
Private Const A205      As Long = -701558691
Private Const A206      As Long = 38016083
Private Const A207      As Long = -660478335
Private Const A208      As Long = -405537848
Private Const A209      As Long = 568446438
Private Const A210      As Long = -1019803690
Private Const A211      As Long = -187363961
Private Const A212      As Long = 1163531501
Private Const A213      As Long = -1444681467
Private Const A214      As Long = -51403784
Private Const A215      As Long = 1735328473
Private Const A216      As Long = -1926607734

'Pass 3
Private Const S301      As Long = 4
Private Const S302      As Long = 11
Private Const S303      As Long = 16
Private Const S304      As Long = 23
Private Const A301      As Long = -378558
Private Const A302      As Long = -2022574463
Private Const A303      As Long = 1839030562
Private Const A304      As Long = -35309556
Private Const A305      As Long = -1530992060
Private Const A306      As Long = 1272893353
Private Const A307      As Long = -155497632
Private Const A308      As Long = -1094730640
Private Const A309      As Long = 681279174
Private Const A310      As Long = -358537222
Private Const A311      As Long = -722521979
Private Const A312      As Long = 76029189
Private Const A313      As Long = -640364487
Private Const A314      As Long = -421815835
Private Const A315      As Long = 530742520
Private Const A316      As Long = -995338651

'Pass 4
Private Const S401      As Long = 6
Private Const S402      As Long = 10
Private Const S403      As Long = 15
Private Const S404      As Long = 21
Private Const A401      As Long = -198630844
Private Const A402      As Long = 1126891415
Private Const A403      As Long = -1416354905
Private Const A404      As Long = -57434055
Private Const A405      As Long = 1700485571
Private Const A406      As Long = -1894986606
Private Const A407      As Long = -1051523
Private Const A408      As Long = -2054922799
Private Const A409      As Long = 1873313359
Private Const A410      As Long = -30611744
Private Const A411      As Long = -1560198380
Private Const A412      As Long = 1309151649
Private Const A413      As Long = -145523070
Private Const A414      As Long = -1120210379
Private Const A415      As Long = 718787259
Private Const A416      As Long = -343485551

Private Const Top16Bits As Long = &HFFFF0000
Private Const Bot16Bits As Long = &HFFFF&
Private Const Bot8Bits  As Long = &HFF&
Private Const Bit16Only As Long = &H10000

Private Const BlockSize As Long = 64

'variables, types, and enums
Private Type Segs
    P(1 To 4)           As Long
End Type
Private Digest          As Segs
Public Enum SignatureLength
    [Short] = 4
    [Medium] = 16
    [Long] = 32
End Enum

'local properties
Private myMsgDigest4    As String
Private myMsgDigest16   As String
Private myMsgDigest32   As String

Private Function BuildLeaves(Key As String) As Long

  'this builds all nodes for a tree, the weight assigned to the leaves however depends on
  'the key rather than on the character frequency (which would be used in a Huffman Tree)

  Dim IxLeaf, IxKey, TotalWeight, Rand

#If Debugging Then
    fTest.tvwTree.Nodes.Clear
    fTest.lstCodes.Clear
#End If
    ReDim Nodes(0 To 510)

    If Len(Key) Then
        For IxLeaf = LBound(Nodes) To UBound(Nodes)
            If IxKey = Len(Key) Then
                IxKey = 0
            End If
            IxKey = IxKey + 1 'cycles through key
            With Nodes(IxLeaf)
                .Parent = 0 'no parents or children yet
                .Child1 = 0
                .Child2 = 0
                If IxLeaf < 256 Then 'this is a leaf for sure

                    'this rather complicated algorithm assigns a weight to a leaf, this weight should
                    'be widely spread to make the tree unbalanced, and chaotic to react to input
                    'changes with 'unpredictable' output changes

                    Rand = Int(Rnd(-Asc(Mid$(Key, IxKey, 1)) - IxLeaf Xor IxKey) * 2674317)
                    Do
                        .Weight = (Rand + IxLeaf) Mod (Rnd ^ 11 * 473 * Asc(Mid$(Key, Int(Rnd * Len(Key) + 1), 1)) + 1)
                    Loop Until .Weight

                    'we need the total weight of all leaves to recognize the root later on
                    TotalWeight = TotalWeight + .Weight

                  Else 'this will be a parent node'NOT IXLEAF...
                    .Weight = 0 'will later have the combined weight of her children
                End If
            End With 'NODES(IXLEAF)
        Next IxLeaf
        BuildLeaves = TotalWeight 'return total weight of all leaves
      Else 'LEN(KEY) = FALSE
        Err.Raise 1001, "cEncDec", "The key is missing."
    End If

    'create initial hash
    Hash = (TotalWeight Xor TotalWeight \ 256 Xor TotalWeight \ 256 \ 256 Xor TotalWeight \ 256 \ 256 \ 256) And Bot8Bits
    'init randomizer for hash
    Rnd -TotalWeight * Hash

End Function

Private Function BuildTree(ExpectedRootWeight As Long) As Long

  'this creates a tree in Huffman fashion, however the node-weights do not depend on
  'character frequency but on the key (see BuildLeaves)

  Dim ChildCount, IxNode, IxParent, IxFirstChild, IxSecondChild, LowestWeight

    IxParent = 255 'leaves are in 0 .. 255, parents, grandparents (and finally root) will be in 256 .. 512
    Do
        IxParent = IxParent + 1
        With Nodes(IxParent)
            For ChildCount = 1 To 2 'find two children for the next parent
                IxFirstChild = IxSecondChild '2nd index is free again on 2nd time Pass
                LowestWeight = MaxLong
                For IxNode = 0 To IxParent - 1 'find parentless living Nodes with the lowest Weight (leaf or intermediate)
                    If Nodes(IxNode).Parent = 0 And Nodes(IxNode).Weight > 0 And Nodes(IxNode).Weight < LowestWeight Then
                        LowestWeight = Nodes(IxNode).Weight
                        IxSecondChild = IxNode 'remember that child's index
                    End If
                Next IxNode
                If LowestWeight < MaxLong Then 'found a suitable child - adopt it
                    Nodes(IxSecondChild).Parent = IxParent 'tell child who her parent is
                    .Weight = .Weight + LowestWeight 'add child weight to parent weight
                End If
            Next ChildCount
            .Child1 = IxFirstChild 'tell parent who her children are
            .Child2 = IxSecondChild
        End With 'NODES(IXPARENT)
    Loop Until Nodes(IxParent).Weight = ExpectedRootWeight 'bail out if the root was just created
    BuildTree = IxParent 'return root index
#If Debugging Then
    ShowNodeWithChildren -1, IxParent, vbNullString, vbNullString
#End If

End Function

Public Property Get BytesPerSecond() As Long
Attribute BytesPerSecond.VB_Description = "Public Property"

    BytesPerSecond = Speed

End Property

Private Sub Class_Initialize()

  Dim IxMask

    For IxMask = LBound(Masks) To UBound(Masks)
        Masks(IxMask) = 2 ^ IxMask 'Masks are initialized only once; speed up decryption
    Next IxMask

End Sub

Private Sub Class_Terminate()

  'erase sensitive info form memory

    Erase Nodes, Codes, Digest.P

End Sub

Private Sub CreateCodes(Root As Long)

  'this scans the tree from leaves to root and creates a table of variable length codes

  Dim IxLeaf, IxChild, IxParent, Code As String

    ReDim Codes(0 To 255)
    MinLen = MaxLong
    MaxLen = -1
    For IxLeaf = LBound(Codes) To UBound(Codes) 'all leaves
        Code = vbNullString
        If Nodes(IxLeaf).Parent Then 'not an orphan (don't think there are any in this tree but just to be sure)
            IxChild = IxLeaf
            Do 'climb up to root
                IxParent = Nodes(IxChild).Parent
                Code = IIf(IxChild = Nodes(IxParent).Child1, "0", "1") & Code
                IxChild = IxParent
            Loop Until IxParent = Root
            Codes(IxLeaf) = Code
            If Len(Code) < MinLen Then
                MinLen = Len(Code)
            End If
            If Len(Code) > MaxLen Then
                MaxLen = Len(Code)
            End If
            If Len(Code) > 7 Then 'if the code is longer than 7 bits then
                IxSlack = IxLeaf  'that's a good candidate for the slack bits
            End If
        End If
    Next IxLeaf

End Sub

Private Function CreateTree(Key As String) As Long

    CreateTree = BuildTree(BuildLeaves(Key))

End Function

Public Function Decrypt(Data As String, Key As String) As String
Attribute Decrypt.VB_Description = "This reads the input bit stream and climbs down the tree until a leaf is found; that leaf's index (after digest) is the Ascii value of clear character to return"

  'this reads the input bit stream and climbs down the tree until a leaf is found;
  'that leaf's index (after hash) is the Ascii value of clear character to return

  Dim Root, IxParent, IxChild, Pointer, IxMask, Coding, Ascii, Chunk As String

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

    'decrypt data
    IxParent = Root 'start at root
    For Pointer = 1 To Len(Data)
        Coding = Asc(Mid$(Data, Pointer, 1))
        For IxMask = UBound(Masks) To LBound(Masks) Step -1 'climb down the tree
            If Coding And Masks(IxMask) Then
                IxChild = Nodes(IxParent).Child2
              Else 'NOT CODING...
                IxChild = Nodes(IxParent).Child1
            End If
            If Nodes(IxChild).Child1 = 0 And Nodes(IxChild).Child2 = 0 Then 'that's a leaf
                Ascii = IxChild Xor Hash
                Chunk = Chunk & Chr$(Ascii) 'append clear char
                Hash = (Ascii Xor Hash) \ 2 + Rnd * 128 'update hash
                IxParent = Root 'go back to root
                If Len(Chunk) = ChunkSize Then
                    Decrypt = Decrypt & Chunk 'append chunk
                    Chunk = vbNullString
                End If
              Else 'not a leaf'NOT NODES(IXCHILD).CHILD1...
                IxParent = IxChild 'climb down further
            End If