'**************************************
' Name: LZSS Compress/Decompress
' Description:This is a standard LZSS co
'     mpression/decompression engine. It is wr
'     itten in VB for learning purposes, and s
'     hould be converted to C/C++ if it is to 
'     be used with large amounts of data. It u
'     ses a dictionary compression algorithm (
'     like ZIP,ARJ and others) and works the b
'     est on data with a lot of repetitions.
' By: Jesper Soderberg
'
'
' Inputs:sCompData - the string to be co
'     mpressed, sDecompData - the string to be
'     decompressed
'
' Returns:Should be obvious
'
'Assumes:None
'
'Side Effects:None
'
'Warranty:
'code provided by Planet Source Code(tm)
'     (http://www.Planet-Source-Code.com) 'as 
'     is', without warranties as to performanc
'     e, fitness, merchantability,and any othe
'     r warranty (whether expressed or implied
'     ).
'Terms of Agreement:
'By using this source code, you agree to
'     the following terms...
' 1) You may use this source code in per
'     sonal projects and may compile it into a
'     n .exe/.dll/.ocx and distribute it in bi
'     nary format freely and with no charge.
' 2) You MAY NOT redistribute this sourc
'     e code (for example to a web site) witho
'     ut written permission from the original 
'     author.Failure to do so is a violation o
'     f copyright laws.
' 3) You may link to this code from anot
'     her website, provided it is not wrapped 
'     in a frame.
' 4) The author of this code may have re
'     tained certain additional copyright righ
'     ts.If so, this is indicated in the autho
'     r's description.
'**************************************

Option Explicit


Public Function sCompress(sCompData As String) As String

    Dim lDataCount As Long
    Dim lBufferStart As Long
    Dim lMaxBufferSize As Long
    Dim sBuffer As String
    Dim lBufferOffset As Long
    Dim lBufferSize As Long
    Dim sDataControl As String
    Dim bDataControlChar As Byte
    Dim lControlCount As Long
    Dim bControlPos As Byte
    Dim bCompLen As Long
    Dim lCompPos As Long
    Dim bMaxCompLen As Long
    
    lMaxBufferSize = 65535
    bMaxCompLen = 255
    lBufferStart = 0
    sDataControl = ""
    bDataControlChar = 0
    bControlPos = 0
    lControlCount = 0


    If Len(sCompData) > 4 Then
        sCompress = Left(sCompData, 4)


        For lDataCount = 5 To Len(sCompData)


            If lDataCount > lMaxBufferSize Then
                lBufferSize = lMaxBufferSize
                lBufferStart = lDataCount - lMaxBufferSize
            Else
                lBufferSize = lDataCount - 1
                lBufferStart = 1
            End If

            sBuffer = Mid(sCompData, lBufferStart, lBufferSize)
            If Len(sCompData) - lDataCount < bMaxCompLen Then bMaxCompLen = Len(sCompData) - lDataCount
            lCompPos = 0


            For bCompLen = 3 To bMaxCompLen Step 3


                If bCompLen > bMaxCompLen Then
                    bCompLen = bMaxCompLen
                End If

                lCompPos = InStr(1, sBuffer, Mid(sCompData, lDataCount, bCompLen), 0)


                If lCompPos = 0 Then


                    If bCompLen > 3 Then


                        While lCompPos = 0
                            lCompPos = InStr(1, sBuffer, Mid(sCompData, lDataCount, bCompLen - 1), 0)
                            If lCompPos = 0 Then bCompLen = bCompLen - 1
                        Wend

                    End If

                    bCompLen = bCompLen - 1
                    Exit For
                End If

            Next



            If bCompLen > bMaxCompLen And lCompPos > 0 Then
                bCompLen = bMaxCompLen
                lCompPos = InStr(1, sBuffer, Mid(sCompData, lDataCount, bCompLen), 0)
            End If



            If lCompPos > 0 Then
                lBufferOffset = lBufferSize - lCompPos + 1
                sCompress = sCompress & Chr((lBufferOffset And &HFF00) / &H100) & Chr(lBufferOffset And &HFF) & Chr(bCompLen)
                lDataCount = lDataCount + bCompLen - 1
                bDataControlChar = bDataControlChar + 2 ^ bControlPos
            Else
                sCompress = sCompress & Mid(sCompData, lDataCount, 1)
            End If

            bControlPos = bControlPos + 1


            If bControlPos = 8 Then
                sDataControl = sDataControl & Chr(bDataControlChar)
                bDataControlChar = 0
                bControlPos = 0
            End If

            lControlCount = lControlCount + 1
        Next

        If bControlPos <> 0 Then sDataControl = sDataControl & Chr(bDataControlChar)
        sCompress = Chr((lControlCount And &H8F000000) / &H1000000) & Chr((lControlCount And &HFF0000) / &H10000) & Chr((lControlCount And &HFF00) / &H100) & Chr(lControlCount And &HFF) & Chr((Len(sDataControl) And &H8F000000) / &H1000000) & Chr((Len(sDataControl) And &HFF0000) / &H10000) & Chr((Len(sDataControl) And &HFF00) / &H100) & Chr(Len(sDataControl) And &HFF) & sDataControl & sCompress
    Else
        sCompress = sCompData
    End If

End Function



Public Function sDecompress(sDecompData As String) As String

    Dim lControlCount As Long
    Dim lControlPos As Long
    Dim bControlBitPos As Byte
    Dim lDataCount As Long
    Dim lDataPos As Long
    Dim lDecompStart As Long
    Dim lDecompLen As Long
    


    If Len(sDecompData) > 4 Then
        lControlCount = Asc(Left(sDecompData, 1)) * &H1000000 + Asc(Mid(sDecompData, 2, 1)) * &H10000 + Asc(Mid(sDecompData, 3, 1)) * &H100 + Asc(Mid(sDecompData, 4, 1))
        lDataCount = Asc(Mid(sDecompData, 5, 1)) * &H1000000 + Asc(Mid(sDecompData, 6, 1)) * &H10000 + Asc(Mid(sDecompData, 7, 1)) * &H100 + Asc(Mid(sDecompData, 8, 1)) + 9
        sDecompress = Mid(sDecompData, lDataCount, 4)
        lDataCount = lDataCount + 4
        bControlBitPos = 0
        lControlPos = 9


        For lDataPos = 1 To lControlCount


            If 2 ^ bControlBitPos = (Asc(Mid(sDecompData, lControlPos, 1)) And 2 ^ bControlBitPos) Then
                lDecompStart = Len(sDecompress) - (CLng(Asc(Mid(sDecompData, lDataCount, 1))) * &H100 + CLng(Asc(Mid(sDecompData, lDataCount + 1, 1)))) + 1
                lDecompLen = Asc(Mid(sDecompData, lDataCount + 2, 1))
                sDecompress = sDecompress & Mid(sDecompress, lDecompStart, lDecompLen)
                lDataCount = lDataCount + 3
            Else
                sDecompress = sDecompress & Mid(sDecompData, lDataCount, 1)
                lDataCount = lDataCount + 1
            End If

            bControlBitPos = bControlBitPos + 1


            If bControlBitPos = 8 Then
                bControlBitPos = 0
                lControlPos = lControlPos + 1
            End If

        Next

    Else
        sDecompress = sDecompData
    End If

End Function

'Put a two command buttons (Command1 and
'     Command2) on to a form and paste the fol
'     lowing on to it as well:
Option Explicit
Private Const sFileName = "c:\compressthis.exe" ' the file To be compressed


Private Sub Command1_Click() 'Compress the file

    Dim sReturn As String
    Dim sFileData As String
    
    Open sFileName For Binary As #1
    sFileData = Input(LOF(1), #1)
    Close #1
    sReturn = sCompress(sFileData)
    Debug.Print Len(sReturn), Len(sFileData)
    
    Open Left(sFileName, Len(sFileName) - 3) & "wnc" For Output As #1
    Print #1, sReturn;
    Close #1
End Sub



Private Sub Command2_Click() 'Decompress the file

    Dim sReturn As String
    Dim sFileData As String
    
    Open Left(sFileName, Len(sFileName) - 4) & ".wnc" For Binary As #1
    sFileData = Input(LOF(1), #1)
    sReturn = sDecompress(sFileData)
    Close #1
    Debug.Print Len(sReturn), Len(sFileData)
    
    Open Left(sFileName, Len(sFileName) - 4) & "2" & Right(sFileName, 4) For Output As #1
    Print #1, sReturn;
    Close #1
End Sub