'**************************************
' 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