Points for cvidler

Ok here it is the following is a class module so just open notepad paste all this in, and save it as 'clsLZW.cls' and add it to your project. To use it simple include the following lines...

'Declare class before using it
Dim LZW As New clsLZW

'Compress
Comp$ = LZW.Compress(StringHere)

'Decompress
DeComp$ = LZW.Decompress(CompressedStringHere)

'Destroy class when done
Set LZW = Nothing

I ask you not to distribute this class as yet, as I have not finished fully testing it properly. It appears to work properly, the only bug I know of is if you give the Decompress method invalid data (ie. not compressed or corrupt) it will most likely result in an endless loop, that will take forever and chew up memory.


'-----------Cut Here-----------
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsLZW"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Description = "Compress and Decompress data using a version of the LZW (Lempel Ziv Welch) algorithm."
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
DefLng A-Z
Option Explicit

'-----------------------------------------------------------------
'Compression
Private PrefixA(), SuffixA(), CodeA()
Private UsedA()
Private InBuffer$, IAddress, IEndAddress, Iseg
Private OutBuffer$, OStartAddress, OAddress, OEndAddress, Oseg
Private CodeSize, CurrentBit, Char&
Private Shift(12) As Long
Private MaxCode
Private InString As String, OutString As String

'-----------------------------------------------------------------
'Decompression
Private OutCodeA()                      'simulates a hardware stack
Private BytesIn&
Private Powers()
Private LongPowers() As Long
Private Masks()

Public Event CompressionProgress(Complete As Integer, CompressionRatio As Single)
Attribute CompressionProgress.VB_Description = "Informs about progress and compression ratio while compressing."
Public Event DecompressionProgress(Complete As Integer)
Private Static Function GetCode(InString$)
    Dim BitsLeft&, TempChar&, WorkCode&
   
    On Local Error Resume Next
    If BitsLeft = 0 Then
        TempChar = GetByte(InString$)
        BitsLeft = 8
    End If
    WorkCode& = TempChar \ Powers(8 - BitsLeft)
    Do While CodeSize > BitsLeft
        TempChar = GetByte(InString)
        WorkCode& = WorkCode& Or TempChar * LongPowers(BitsLeft)
        BitsLeft = BitsLeft + 8
    Loop
    BitsLeft = BitsLeft - CodeSize
    GetCode = WorkCode& And Masks(CodeSize)
End Function

Private Static Function GetByte(InString$)
    On Local Error Resume Next
    GetByte = Asc(Mid$(InString, IAddress + 1, 1))
    BytesIn& = BytesIn& + 1
    IAddress = IAddress + 1
End Function


Public Function Decompress(Data As String) As String
Attribute Decompress.VB_Description = "Decompresses compressed data with the LZW algorithm."
    Dim A&, FreeCode&, StartCode&, Code&, CurCode&, OldCode&
    Dim FinChar&, FileLength&, OutputCounter&, Percentage!
    Dim NewEntries&, IgnoreNext&, InCode&, OutCount&
    On Local Error Resume Next
   
    InString = Data
   
    'Prefix & Suffix of each code
    ReDim PrefixA(4097)
    ReDim SuffixA(4097)
    ReDim UsedA(4097)
    ReDim OutCodeA(4097)               'simulates a hardware stack
   
    'Used for screen updating
    'Dim BytesIn&
    'Powers of two
    ReDim Powers(7)
    ReDim LongPowers(12) As Long
    'Mask for each codesize
    ReDim Masks(12)
    'Current codesize
    'Dim CodeSize
   
    'Initialize each array
    For A = 0 To 7: Powers(A) = 2 ^ A: Next
    For A = 0 To 12: LongPowers(A) = 2 ^ A: Next
    For A = 1 To 12: Masks(A) = (2 ^ A) - 1: Next
   
    'Initialize each disk buffer
    'InBuffer$ = String$(5000, 0)
    'OutBuffer$ = String$(5000, 0)
   
    'Find address of output buffer
    OAddress = 0
    OutString = ""
    'OEndAddress = OAddress + 5000
    'OStartAddress = OAddress
    BytesIn& = 0
   
    'Initialise Input buffer
    'IStartAddress = 0
    IAddress = 0
    'IAddress = IStartAddress + 5000
    'IEndAddress = 5000
   
    'First code is 259
    FreeCode = 259
    StartCode = 259
    'First codesize is 9 bits
    CodeSize = 9
    'Get First code(special case)
    Code = GetCode(InString)
    CurCode = Code
    OldCode = Code
    FinChar = Code
    PutByte FinChar
   
    FileLength& = Len(InString)
    'Main decompression loop
    Do
        'Update screen every 1,024 codes
        OutputCounter = OutputCounter + 1
        If OutputCounter = 1024 Then
            Percentage! = (100& * BytesIn&) \ FileLength&
            RaiseEvent DecompressionProgress(CInt(Percentage!))
            OutputCounter = 0
        End If
   
GetCode:
        'Get code from input file
        Code = GetCode(InString)
        'Process code
        Select Case Code
        'End of file code
        Case 256
            Decompress = OutString
            Exit Function
        'Increase code size code
        Case 257
            CodeSize = CodeSize + 1
        Case 258
            RebuildTable NewEntries
            FreeCode = NewEntries + StartCode
            CodeSize = 9
   
            If FreeCode > 4096 Then
                FreeCode = StartCode
                Code = GetCode(InString)
   
                CurCode = Code
                OldCode = Code
   
                FinChar = Code
                PutByte FinChar
            Else
                'prevents an invalid code from entering the table
                IgnoreNext = True
            End If
   
        'Process a code
        Case Else
   
            CurCode = Code
            InCode = Code
            'Do we have this string yet?
            If Code >= FreeCode Then
                'If Code>FreeCode then stop decompression: this can't be right!
                If Code > FreeCode Then
                    'Close #1, #2
                    'Beep
                    'Screen.ActiveForm.Caption = "Bad LZW Code in File, Can't decompress!"
                    'MsgBox "Bad LZW Code in compression stream." + vbCrLf + "Source file corrupted, can't continue decompression!", vbCritical + vbSystemModal, "Bad LZW Code in File"
                    'Major Error
                    Error = -1
                    Exit Function
                End If
                'Trick decompressor to use last code
   
                UsedA(Code) = UsedA(Code) + 1
                CurCode = OldCode
                OutCodeA(OutCount) = FinChar
                OutCount = OutCount + 1
            End If
   
            'Does this code represent a string?
            If CurCode >= StartCode Then
                'Get each character from the table and push it onto the stack
   
                Do
                    UsedA(CurCode) = UsedA(CurCode) + 1
                    OutCodeA(OutCount) = SuffixA(CurCode)
                    OutCount = OutCount + 1
                    CurCode = PrefixA(CurCode)
                'keep on doing this until we have a normal character
                Loop Until CurCode <= 255
            End If
            FinChar = CurCode
            OutCodeA(OutCount) = FinChar
            'Pop all the codes of the stack and put them into the output file
            For A = OutCount To 0 Step -1
                PutByte OutCodeA(A)
            Next
            OutCount = 0
            'Put the new string into the table
            If IgnoreNext Then
                IgnoreNext = False
            Else
                PrefixA(FreeCode) = OldCode
                SuffixA(FreeCode) = FinChar
                FreeCode = FreeCode + 1
            End If
            OldCode = InCode
        End Select
    Loop

End Function

Private Static Sub PutByte(A)
    On Local Error Resume Next
    OutString = OutString + Chr$(A)
    OAddress = OAddress + 1
End Sub


Public Function Compress(Data As String) As String
Attribute Compress.VB_Description = "Compresses data with the LZW algorithm."
    Dim CurrentLoc&, StartCode&, NextCode&, Prefix&
    Dim BytesOut&, Suffix&, Index&, Found&, NewEntries&
    Dim PrintCounter&, A&
   
    On Local Error Resume Next
   
    InString = Data
   
    ReDim PrefixA(6576), SuffixA(6576), CodeA(6576)
    ReDim UsedA(4096)
   
    Shift(0) = 1
    Shift(1) = 2
    Shift(2) = 4
    Shift(3) = 8
    Shift(4) = 16
    Shift(5) = 32
    Shift(6) = 64
    Shift(7) = 128
    Shift(8) = 256
    Shift(9) = 512
    Shift(10) = 1024
    Shift(11) = 2048
    Shift(12) = 4096
   
    InBuffer$ = String$(4000, 0)   'input buffer
    OutBuffer$ = String$(4000, 0)  'output buffer
   
    IAddress = 0
    OAddress = 0
    OEndAddress = OAddress + 4000           'End address of  buffer
    OStartAddress = OAddress                'Start of buffer
   
    'CurrentLoc& - position in input file
    CurrentLoc& = 2
   
    'Compression codes:
    'Code 256 = end of file
    'Code 257 = increase code size
    'Code 258 = rebuild table
    'Code 259 - 4095 = available for strings
    StartCode = 259                 'First LZW code that is available
    NextCode = 259
    'The maximum code that can be represented in 9 bits
    MaxCode = 512
    'Start with 9 bit code size
    CodeSize = 9
    'Current bit position in Char& - use for Put_Code
    CurrentBit = 0
    'Char& is a temporary buffer; accumulates codes from main program and
    'puts them in the output file once complete bytes have been
    'built
    Char& = 0
   
    GoSub ClearTable
    'Get first byte from file(it's a special case)
    Prefix = Get_Byte(InString)
   
    'Main compression loop
    Do
        Do
   
            If CurrentLoc& > Len(InString) Then
                Put_Code Prefix
                Put_Code 256
                Put_Code 0: Put_Code 0
                'OutBuffer$ = Left$(OutBuffer$, OAddress - OStartAddress)
                BytesOut& = Len(OutString) + (OAddress - OStartAddress)
                'Screen.ActiveForm.Caption = "100% done --- Compression " + Str$(100 - ((100& * BytesOut&) \ LOF(1))) + "%"
                'OutString = OutString + OutBuffer$
                Compress = OutString
                'Put #2, , OutBuffer$
                'Close #1, #2
                Exit Function
            Else
                'Dummy% = DOEVENTS()
                Suffix = Get_Byte(InString)
                CurrentLoc& = CurrentLoc& + 1
                'We now have a Prefix:Suffix to search for.
                'If the search fails, put the Prefix in the output file
                'and set the Prefix equal to the character which caused
                'the failure.
   
                Hash Prefix, Suffix, Index, Found
                If Found = True Then
                    Prefix = CodeA(Index)
                    'update how many times this string was used
                    UsedA(Prefix) = UsedA(Prefix) + 1
                End If
            End If
        Loop While Found = True
   
        'only increase the code size when required
        Do While Prefix >= MaxCode And CodeSize < 12
            Put_Code 257
            MaxCode = MaxCode * 2
            CodeSize = CodeSize + 1
        Loop
   
        Put_Code Prefix
   
        'Put the new string into the hash table.
        PrefixA(Index) = Prefix
        SuffixA(Index) = Suffix
        CodeA(Index) = NextCode  'remember this string's code
   
        'Prefix is now equal to the character that caused the failure now.
        Prefix = Suffix
   
        NextCode = NextCode + 1
        'if there are too many strings then rebuild the encoding table
        If NextCode > 4096 Then
   
            Put_Code 258 'send rebuild table code to decompressor
   
            Rebuild_Table NewEntries
            NextCode = NewEntries + StartCode
   
            If NextCode > 4096 Then
                GoSub ClearTable
                NextCode = StartCode        'reset NextCode to top of tree
            End If
   
            CodeSize = 9
            MaxCode = 512
   
   
        End If
   
        'let the impatient user know we haven't hung up (yet!)
        PrintCounter = PrintCounter + 1     'see if time to update the
        If PrintCounter = 512 Then          'screen
            'BytesOut& = Len(OutString) '+ (OAddress - OStartAddress)
            RaiseEvent CompressionProgress((CurrentLoc& / Len(InString)) * 100, (Len(OutString) / Len(InString)) * 100)
            PrintCounter = 0
        End If
    Loop
   
'clears the hash table
ClearTable:
    For A = 0 To 6576
        PrefixA(A) = -1
        SuffixA(A) = -1
        CodeA(A) = -1
    Next
Return

End Function



'Reads one byte from the input buffer, and fills the buffer if it's emty.
Private Static Function Get_Byte(InString$)
    On Local Error Resume Next
    Get_Byte = Asc(Mid$(InString$, IAddress + 1, 1))
    IAddress = IAddress + 1
End Function


'Attempts to finds a prefix:suffix string.
Private Sub Hash(Prefix, Suffix, Index, Found)
    Dim Offset&
   
    On Local Error Resume Next
   
    Index = (Prefix * 256& Xor Suffix) Mod 6577 'XOR hashing
    If Index = 0 Then  'is Index lucky enough to be 0?
        Offset = 1     'Set offset to 1, because 6577-0=6577
    Else
        Offset = 6577 - Index
    End If
    Do 'until we find a match or don't
        If CodeA(Index) = -1 Then      'is there nothing here?
            Found = False             'yup, not found
            Exit Sub
        'is this entry what we're looking for?
        ElseIf PrefixA(Index) = Prefix And SuffixA(Index) = Suffix Then
            Found = True              'yup, found
            Exit Sub
        Else 'retry until we find what were looking for or we find a blank
             'entry
            Index = Index - Offset
            If Index < 0 Then 'is index too far down?
                Index = Index + 6577 'yup, bring it up then
            End If
        End If
    Loop
End Sub

'Throws a byte into the output buffer and writes the buffer if it's full.
Private Static Sub Put_Byte(A)
    On Local Error Resume Next
    OutString = OutString + Chr$(A)
    OAddress = OAddress + 1
End Sub


Private Sub RebuildTable(NewEntries)
    On Local Error Resume Next
    ReDim PA(4095), SA(4095), UA(4095) As Long, PnA(4095), CA(4095)
    ReDim LocationA(4095)
   
    Dim StartCode, OldCode
   
    NumEntries = 0
    For A = StartCode To 4095
        If UsedA(A) > 0 Then
            UsedA(A) = 0
            P = PrefixA(A): s = SuffixA(A)
            PA(NumEntries) = P
            SA(NumEntries) = s
            UA(NumEntries) = P * 4096& + s
            CA(A) = NumEntries
            NumEntries = NumEntries + 1
        End If
    Next

    NumEntries = NumEntries - 1
    For A = 0 To NumEntries
        PnA(A) = A
    Next
 
    Middle = NumEntries \ 2
    Do
        For A = 0 To NumEntries - Middle
            If UA(PnA(A)) > UA(PnA(A + Middle)) Then
                Swap PnA(A), PnA(A + Middle)
                SwapFlag = True
                CompareLow = A - Middle
                CompareHigh = A
                Do While CompareLow >= 0
                    If UA(PnA(CompareLow)) > UA(PnA(CompareHigh)) Then
                        Swap PnA(CompareLow), PnA(CompareHigh)
                        CompareHigh = CompareLow
                        CompareLow = CompareLow - Middle
                    Else
                        Exit Do
                    End If
                Loop
            End If
        Next
        Middle = Middle \ 2
    Loop While Middle > 0
   
    For A = 0 To NumEntries
        LocationA(PnA(A)) = A
    Next
   
    For A1 = 0 To NumEntries
        A = PnA(A1)
     
        P = PA(A)
        s = SA(A)
        If P >= StartCode Then
            P = StartCode + LocationA(CA(P))
        End If
        If s >= StartCode Then
            s = StartCode + LocationA(CA(s))
        End If
       
        PrefixA(A1 + StartCode) = P
        SuffixA(A1 + StartCode) = s
    Next
   
    If OldCode >= StartCode Then
        OldCode = StartCode + LocationA(CA(OldCode))
    End If
    NewEntries = NumEntries + 1

End Sub


'Throws one multi-bit code to the output file.
Private Static Sub Put_Code(A)
    On Local Error Resume Next
    If A >= MaxCode Then MsgBox Str$(A) + ">=" + Str$(MaxCode)

    Char& = Char& + A * Shift(CurrentBit)
    CurrentBit = CurrentBit + CodeSize
    Do While CurrentBit > 7
        Put_Byte Char& And 255
        Char& = Char& \ 256
        CurrentBit = CurrentBit - 8
    Loop
End Sub


'This is the "experimental" part of the program. This procedure eliminates
'any strings which are not used in the encoding table: the usual result of
'doing this is greater compression.
'It isn't documented well yet... I'm still working on it.
Private Sub Rebuild_Table(NewEntries)
    On Local Error Resume Next
    Dim PA(4096), SA(4096), UA(4096) As Long, PnA(4096), CA(4096)
    Dim LocationA(4096)
   
    Dim StartCode, MaxCode, Prefix
    NumEntries = 0
   
    For A = 0 To 6576
        C = CodeA(A)
        If C <> -1 Then 'valid code?
            If UsedA(C) > 0 Then 'was it used at all?
                UsedA(C) = 0
                P = PrefixA(A): s = SuffixA(A)
                PA(NumEntries) = P          'put it into a temporary table
                SA(NumEntries) = s
                UA(NumEntries) = P * 4096& + s
                CA(C) = NumEntries
                NumEntries = NumEntries + 1
            End If
        End If
    Next
   

    NumEntries = NumEntries - 1
    For A = 0 To NumEntries
        PnA(A) = A
    Next
        'sort the table according to it's prefix:suffix
    Middle = NumEntries \ 2
    Do
        For A = 0 To NumEntries - Middle
            If UA(PnA(A)) > UA(PnA(A + Middle)) Then
                Swap PnA(A), PnA(A + Middle)
                SwapFlag = True
                CompareLow = A - Middle
                CompareHigh = A
                Do While CompareLow >= 0
                    If UA(PnA(CompareLow)) > UA(PnA(CompareHigh)) Then
                        Swap PnA(CompareLow), PnA(CompareHigh)
                        CompareHigh = CompareLow
                        CompareLow = CompareLow - Middle
                    Else
                        Exit Do
                    End If
                Loop
               
            End If
        Next
       
        Middle = Middle \ 2
    Loop While Middle > 0
   
   
    For A = 0 To NumEntries
        LocationA(PnA(A)) = A
    Next
    'clear the old hash table
    For A = 0 To 6576
        PrefixA(A) = -1
        SuffixA(A) = -1
        CodeA(A) = -1
    Next
   
    'put each prefix:suffix into the hash table
    For A1 = 0 To NumEntries
        A = PnA(A1)
       
        P = PA(A)
        s = SA(A)
        If P >= StartCode Then 'is it pointing twards a string?
            P = StartCode + LocationA(CA(P)) 'yup; update the pointer
        End If
        If s >= StartCode Then
            s = StartCode + LocationA(CA(s))
        End If
        'where does this prefix:suffix go?
        Hash P, s, Index, 0
        'put it there
        PrefixA(Index) = P
        SuffixA(Index) = s
        CodeA(Index) = A1 + StartCode
       
    Next
    '# of entries in the hash table now
    NewEntries = NumEntries + 1
End Sub


Private Sub Swap(Var1, Var2)
    Temp = Var2
    Var2 = Var1
    Var1 = Temp
End Sub
'-----------Cut Here-----------

Once again please do not distribute this code.