clszip.cls

纯粹用vb实现的压缩算法

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsZip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'VB性能大讨论: 顶级专家用VB写的压缩算法居然比C++编写的WinRar压缩算法慢100倍,

'该代码是一位俄罗斯专家写的,极具收藏价值和实用价值,只可惜速度慢了一些.

'现附源代码供大家学习和收藏,同时也请各位高手对源代码分析, 看看能不能进行一些优化. 请大家把优化后的测试结果贴出来供其他人学习和讨论.

'测试程序:
'  Dim ObjZip As New ClassZip
'
'  ObjZip.InputFileName = "C:\1\Test.Bmp"
'  ObjZip.InputFileName = "C:\1\Test.Zip"
'  ObjZip.Compress
'
'  ....
'
'=====================================
'下面是 ClassZip的全部源代码
'======================================

Public Event FileProgress(sngPercentage As Single)
Private m_strInputFileName As String
Private m_strOutputFileName As String
Private mintInputFile As Integer
Private mintOutputFile As Integer
Private Const mcintWindowSize As Integer = &H1000
Private Const mcintMaxMatchLen As Integer = 18
Private Const mcintMinMatchLen As Integer = 3
Private Const mcintNull As Integer = &H1000
Private Const mcintByteNotify As Integer = &H1000
Private mabytWindow(mcintWindowSize + mcintMaxMatchLen) As Byte
Private maintWindowNext(mcintWindowSize + 1 + mcintWindowSize) As Integer
Private maintWindowPrev(mcintWindowSize + 1) As Integer
Private mintMatchPos As Integer
Private mintMatchLen As Integer

' *******************************************
' This is for writing the bytes out to a file
' *******************************************

Private mabytOutputBuffer(17) As Byte
Private mbytByteCodeWritten As Byte
Private mbytBitCount As Byte
' LZ signature
Private Const mcstrSignature As String = "FMSLZ1"
Public Property Get InputFileName() As String
' Returns the input file name
InputFileName = m_strInputFileName
End Property

Public Property Let InputFileName(ByVal strValue As String)
'strValue: Set the input file name
m_strInputFileName = strValue
End Property

Public Property Get OutputFileName() As String
'Returns the output file name
OutputFileName = m_strOutputFileName
End Property

Public Property Let OutputFileName(ByVal strValue As String)
'strValue: Set the output file name
m_strOutputFileName = strValue
End Property

Public Sub Compress()

'***********************************************************
'This procedure compresses the input file to the output file
'***********************************************************

Dim intBufferLocation As Integer
Dim intMaxLen As Integer
Dim bytByte As Byte
Dim lngBytesRead As Long
Dim lngFileLength As Long
On Error GoTo PROC_ERR
' Get the next free file id
mintInputFile = FreeFile
'Openz the input file
Open m_strInputFileName For Binary Access Read As mintInputFile
'Try to delete the output file. If it doesn't exist an error is raised
On Error Resume Next
Kill m_strOutputFileName
On Error GoTo PROC_ERR
' Get the next free file id
mintOutputFile = FreeFile
' Open the output file
Open m_strOutputFileName For Binary As mintOutputFile
' Initialize the search buffers
CompressionInitialize
intBufferLocation = 0
intMaxLen = 0
lngFileLength = LOF(mintInputFile)
' write header
Put mintOutputFile, , mcstrSignature
Put mintOutputFile, , lngFileLength
' Prefill the end of the buffer with the first characters in the file
Do While (intMaxLen < mcintMaxMatchLen) And Not EOF(mintInputFile)
Get mintInputFile, , bytByte
mabytWindow(intMaxLen) = bytByte
mabytWindow(intMaxLen + mcintWindowSize) = mabytWindow(intMaxLen)
intMaxLen = intMaxLen + 1
lngBytesRead = lngBytesRead + 1
Loop
' While there is a match in the buffer
Do While (intMaxLen)
' Find the next match
FindMatch (intBufferLocation)
If (mintMatchLen > intMaxLen) Then
   mintMatchLen = intMaxLen
End If
' -> If the match is less than the minimum length, just write out the byte
If (mintMatchLen < mcintMinMatchLen) Then
mintMatchLen = 1
WriteByte mabytWindow(intBufferLocation)
  Else
WriteEntry mintMatchPos, mintMatchLen
End If
' Update the window for each character in the match
Do While (mintMatchLen > 0)
' Remove the current position from the search tables
DeletePosition ((intBufferLocation + mcintMaxMatchLen) And (mcintWindowSize - 1))
intMaxLen = intMaxLen - 1
If Not EOF(mintInputFile) Then
 Get mintInputFile, , bytByte
' Update the window
mabytWindow((intBufferLocation + mcintMaxMatchLen) And (mcintWindowSize - 1)) = bytByte
' Special handling for updating the end of the buffer
If (intBufferLocation + mcintMaxMatchLen >= mcintWindowSize) Then
mabytWindow(intBufferLocation + mcintMaxMatchLen) = bytByte
End If
lngBytesRead = lngBytesRead + 1
intMaxLen = intMaxLen + 1
End If
' Update the search tables
InsertPosition (intBufferLocation)
intBufferLocation = (intBufferLocation + 1) And (mcintWindowSize - 1)
mintMatchLen = mintMatchLen - 1
' Raise the progress event
If (lngBytesRead Mod mcintByteNotify) = 0 Then
 RaiseEvent FileProgress(lngBytesRead / lngFileLength)
End If
Loop
' Raise the progress event
If (lngBytesRead Mod mcintByteNotify) = 0 Then
 RaiseEvent FileProgress(lngBytesRead / lngFileLength)
End If
Loop
' Finish writing the output file
WriteFinish
RaiseEvent FileProgress(1)
' Close the files we opened
Close mintOutputFile
Close mintInputFile
U_ext:
Exit Sub
' if error show message box
PROC_ERR:
MsgBox "Error: Compress", vbCritical, "ULZ"
Resume U_ext
End Sub

Public Sub Decompress()

'*************************************************************
'This procedure decompresses the input file to the output file
'*************************************************************

Dim intCounter As Integer
Dim bytHiByte As Byte
Dim intBufferLocation As Integer
Dim bytLoByte As Byte
Dim bytLength As Byte
Dim intWindowPosition As Integer
Dim bytByte As Byte
Dim intFlags As Integer
Dim lngBytesRead As Long
Dim lngBytesWritten As Long
Dim strSignature As String * 6
Dim lngOriginalFileLen As Long
 
On Error GoTo PROC_ERR
' Get the next free file id
mintInputFile = FreeFile
' Open the input file
Open m_strInputFileName For Binary Access Read As mintInputFile
' Try to delete the output file. If it doesn't exist an error is raised
On Error Resume Next
Kill m_strOutputFileName
On Error GoTo PROC_ERR
' Get the next free file id
mintOutputFile = FreeFile
' Open the output file
Open m_strOutputFileName For Binary As mintOutputFile
' get header
Get mintInputFile, , strSignature
Get mintInputFile, , lngOriginalFileLen
' Check the signature to see if this file is compressed
If strSignature = mcstrSignature Then
' While there is still data to decompress
Do While lngBytesWritten < lngOriginalFileLen
intFlags = Shri(intFlags, 1)
' If the flag byte has been processed, get the next one
If (intFlags And 256) = 0 Then
Get mintInputFile, , bytByte
lngBytesRead = lngBytesRead + 1
intFlags = LongToInt(CLng(bytByte) Or &HFF00&)
End If
' If this byte is not compressed
If (intFlags And 1) Then
' Read from the input and write to the output
Get mintInputFile, , bytByte
lngBytesRead = lngBytesRead + 1
Put mintOutputFile, , bytByte
lngBytesWritten = lngBytesWritten + 1
' Update the window
mabytWindow(intWindowPosition) = bytByte
intWindowPosition = intWindowPosition + 1
intWindowPosition = intWindowPosition And (mcintWindowSize - 1)
Else

' This byte is compressed
' Get the window position and length of the match

Get mintInputFile, , bytHiByte
lngBytesRead = lngBytesRead + 1
Get mintInputFile, , bytLoByte
lngBytesRead = lngBytesRead + 1
intBufferLocation = BufPosition(bytHiByte, bytLoByte)
bytLength = BufLength(bytLoByte)
intCounter = 0

' Read the data from the window and write to the output

Do While intCounter < bytLength
bytByte = mabytWindow((intBufferLocation + intCounter) And (mcintWindowSize - 1))
Put mintOutputFile, , bytByte
lngBytesWritten = lngBytesWritten + 1
mabytWindow(intWindowPosition) = bytByte
intWindowPosition = intWindowPosition + 1
intWindowPosition = intWindowPosition And (mcintWindowSize - 1)
intCounter = intCounter + 1

' Raise the progress event

If (lngBytesWritten Mod mcintByteNotify) = 0 Then
RaiseEvent FileProgress(lngBytesWritten / lngOriginalFileLen)
End If
Loop
End If

' Raise the progress event

If (lngBytesWritten Mod mcintByteNotify) = 0 Then
RaiseEvent FileProgress(lngBytesWritten / lngOriginalFileLen)
End If
Loop
RaiseEvent FileProgress(1)
End If
' Close the files we opened
Close mintOutputFile
Close mintInputFile
U_ext:
Exit Sub
PROC_ERR:
MsgBox "Error: Decompress", vbCritical, "ULZ"
Resume U_ext
End Sub

Private Sub BitSetByte(bytNumber As Byte, bytBitNumber As Byte)
'*********************************************
' This procedure sets a bit in a byte variable
'*********************************************
' Parameterz:
'bytNumber - The byte variable to set the bit in. The result is also returned
' in this parameter
'bytBitNumber - The bit number to clear
On Error GoTo PROC_ERR
bytNumber = bytNumber Or Shlb(1, bytBitNumber)
U_ext:
Exit Sub
PROC_ERR:
MsgBox "Error: Bit Set Byte", vbCritical, "ULZ"
Resume U_ext
End Sub

Private Function BufLength(bytLoByte As Byte) As Byte

'********************************************
'This function returns the length of an entry
'********************************************

' Parameterz
' bytLoByte - The low byte of the entry
' Returnz the length of the entry

On Error GoTo PROC_ERR
BufLength = (bytLoByte And &HF) + mcintMinMatchLen
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: Buffeer Leghth", , vbCritical, "ULZ"
Resume U_ext
End Function

Private Function BufPosition(bytHiByte As Byte, bytLoByte As Byte) As Integer
'******************************************************
' This function returns the window position of an entry
'******************************************************
' bytHiByte - The high byte of the entry
' bytLoByte - The low byte of the entry
' Returnz   : The position of the entry
Dim intPosition As Integer
' if error then show message
On Error GoTo PROC_ERR
intPosition = Shli(bytLoByte And &HF0, 4) + bytHiByte
intPosition = intPosition And &HFFF
BufPosition = intPosition
U_ext:
' exit
Exit Function
PROC_ERR:
' error message
MsgBox "Error: Buffer Position", vbCritical, "ULZ"
Resume U_ext
End Function

Private Sub CompressionInitialize()

' **************************************************************************
' This procedure initializes the module variables for  the compression  and
' decompression routines
' **************************************************************************
Dim intCounter As Integer
On Error GoTo PROC_ERR
' Initialize the window to spaces
For intCounter = 0 To mcintWindowSize + mcintMaxMatchLen - 1
mabytWindow(intCounter) = Asc(" ")
Next intCounter
For intCounter = 0 To mcintWindowSize + mcintWindowSize
maintWindowNext(intCounter) = mcintNull
Next intCounter
For intCounter = 0 To mcintWindowSize
maintWindowPrev(intCounter) = mcintNull
Next intCounter
'Reset write buffer
mabytOutputBuffer(0) = 0
mbytByteCodeWritten = 1
mbytBitCount = 0
U_ext:
' exit
Exit Sub
PROC_ERR:
' error message
MsgBox "Error: Initialize", vbCritical, "ULZ"
Resume U_ext
End Sub

Private Function dblToLong(ByVal dblNumber As Double) As Long
' *****************************************************************************
' This routine does an unsigned conversion from a double Value to a long Value.
' This procedure correctly handles any double value
' *****************************************************************************
'Parameterz
' dblNumber - the double value to convert to a long
' long returnz
Dim dblDivisor As Double
Dim dblTemp As Double
On Error GoTo PROC_ERR
' Visual basic does not allow you enter the value &H100000000 directly,
' so we enter &H7FFFFFFF, double it and add two to create it.
dblDivisor = &H7FFFFFFF
dblDivisor = (dblDivisor * 2) + 2
'if the number is larger than a long can store, then truncate it
If dblNumber > dblDivisor Or dblNumber < 0 Then
dblTemp = dblNumber - (Int(dblNumber / dblDivisor) * dblDivisor)
Else
dblTemp = dblNumber
End If
' if the number is greater than a signed long, convert it to a negative
If dblTemp > &H7FFFFFFF Then
dblToLong = dblTemp - dblDivisor
ElseIf dblTemp < 0 Then
' If the number is negative
dblToLong = dblDivisor + dblTemp
Else
dblToLong = dblTemp
End If
U_ext:
'exit
Exit Function
PROC_ERR:
MsgBox "Error: dbltoLong", vbExclamation, "ULZ"
Resume U_ext
End Function