VB压缩技术

这几天正研究文件压缩解压缩，这是在Homezj的专栏看到的代码，奉为至宝，现转载如下：

这是一个在CSDN论坛中讨论过的压缩算法代码。

与WinRAR以最快方式压缩ZIP比较，
255M的文件
Level=0时 用时24.98秒 大小95.1M
Level=255时 用时30.24秒 大小91.6M

WinRAR最快压缩ZIP 用时 25.2秒 大小58.6M
标准RAR压缩，我看了一下，实在太慢，也就没试了，估计要几分钟才会有结果。

从速度看，基本持平了，这个算法虽然最大压缩能力有限，但感觉设计得很巧妙，每次都基于动态表，使软件可以做得很小巧，资源占用也很少。非常值得收藏！

'测试窗体中的代码
Option Explicit
Private WithEvents ObjZip As ClassZip
Private BgTime As Single
Private Sub Command1_Click()
BgTime = Timer
Command1.Enabled = False
Command2.Enabled = False
With ObjZip
.InputFileName = Text1.Text
.OutputFileName = Text2.Text
.IsCompress = True
.CompressLevel = Val(Text4.Text)
.BeginProcss
End With
Label1.Caption = Round(Timer - BgTime, 2) & "秒"
Command1.Enabled = True
Command2.Enabled = True
End Sub
Private Sub Command2_Click()
BgTime = Timer
Command1.Enabled = False
Command2.Enabled = False
With ObjZip
.InputFileName = Text2.Text
.OutputFileName = Text3.Text
.IsCompress = False
.BeginProcss
End With
Label1 = Round(Timer - BgTime, 2) & "秒"
Command1.Enabled = True
Command2.Enabled = True
End Sub
Private Sub Command3_Click()
ObjZip.CancelProcss = True
End Sub

Private Sub Form_Load()
Set ObjZip = New ClassZip
Command1.Caption = "压缩"
Command2.Caption = "解压"
Command3.Caption = "中断"
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set ObjZip = Nothing
End Sub

Private Sub ObjZip_FileProgress(sngPercentage As Single)
Label1 = Int(sngPercentage * 100) & "%"
End Sub

Private Sub ObjZip_ProcssError(ErrorDescription As String)
MsgBox ErrorDescription
End Sub

'ClassZip类中的声明与属性、方法、事件

Option Explicit
Public Event FileProgress(sngPercentage As Single)
Public Event ProcssError(ErrorDescription As String)
Private Type FileHeader
HeaderTag As String * 3
HeaderSize As Integer
Flag As Byte
FileLength As Long
Version As Integer
End Type
Private mintCompressLevel As Long
Private m_bEnableProcss As Boolean
Private m_bCompress As Boolean
Private m_strInputFileName As String
Private m_strOutputFileName As String
Private Const mcintWindowSize As Integer = &H1000
Private Const mcintMaxMatchLen As Integer = 18
Private Const mcintMinMatchLen As Integer = 3
Private Const mcintNull As Long = &H1000
Private Const mcstrSignature As String = "FMZ"
Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Public Sub BeginProcss()
If m_bCompress Then
Compress
Else
Decompress
End If
End Sub
Private Function LastError(ErrNo As Integer) As String
Select Case ErrNo
Case 1
LastError = "待压缩文件未设置或不存在"
Case 2
LastError = "待压缩文件长度太小"
Case 3
LastError = "待压缩文件已经过压缩"
Case 4
LastError = "待解压文件未设置或不存在"
Case 5
LastError = "待解压文件格式不对或为本软件不能认别的高版本软件所压缩"
Case 254
LastError = "用户取消了操作"
Case 255
LastError = "未知错误"
End Select
End Function
Public Property Get CompressLevel() As Integer
CompressLevel = mintCompressLevel / 16
End Property
Public Property Let CompressLevel(ByVal intValue As Integer)
mintCompressLevel = intValue * 16
If mintCompressLevel < 0 Then mintCompressLevel = 0
End Property

Public Property Get IsCompress() As Boolean
IsCompress = m_bCompress
End Property
Public Property Let IsCompress(ByVal bValue As Boolean)
m_bCompress = bValue
End Property

Public Property Let CancelProcss(ByVal bValue As Boolean)
m_bEnableProcss = Not bValue
End Property

Public Property Get InputFileName() As String
InputFileName = m_strInputFileName
End Property

Public Property Get OutputFileName() As String
OutputFileName = m_strOutputFileName
End Property
Public Property Let OutputFileName(ByVal strValue As String)
m_strOutputFileName = strValue
End Property
Public Property Let InputFileName(ByVal strValue As String)
m_strInputFileName = strValue
End Property
Private Sub Class_Terminate()
m_bEnableProcss = False
End Sub

'类中压缩与解压算法

Private Sub Compress()
Dim lngTemp As Long, intCount As Integer
Dim intBufferLocation As Integer
Dim intMaxLen As Integer
Dim intNext As Integer
Dim intPrev As Integer
Dim intMatchPos As Integer
Dim intMatchLen As Integer
Dim intInputFile As Integer
Dim intOutputFile As Integer
Dim aintWindowNext(mcintWindowSize + 1 + mcintWindowSize) As Integer
Dim aintWindowPrev(mcintWindowSize + 1) As Integer
Dim intByteCodeWritten As Long
Dim intBitCount As Integer
Dim abytWindow(mcintWindowSize + mcintMaxMatchLen) As Byte
Dim udtFileH As FileHeader
Dim strOutTmpFile As String
Dim lngBytesRead As Long
Dim lngFileLength As Long
Dim lngCurWritten As Long
Dim lngInBufLen As Long, abytInputBuffer() As Byte, abytOutputBuffer() As Byte
Dim lngOutBufLen As Long, lngInPos As Long, lngOutPos As Long
Dim intErrNo As Integer
On Error GoTo PROC_ERR
m_bEnableProcss = True
If Len(Dir(m_strInputFileName)) = 0 Or Len(m_strInputFileName) = 0 Then intErrNo = 1: GoTo PROC_ERR
If Len(m_strOutputFileName) = 0 Then m_strOutputFileName = m_strInputFileName
strOutTmpFile = m_strOutputFileName & ".tmp"
If Len(Dir(strOutTmpFile)) > 0 Then Kill strOutTmpFile
If FileLen(m_strInputFileName) < 100 Then intErrNo = 2: GoTo PROC_ERR
intInputFile = FreeFile
Open m_strInputFileName For Binary Access Read As intInputFile
Get intInputFile, , udtFileH
Seek #intInputFile, 1
If udtFileH.HeaderTag = mcstrSignature Then intErrNo = 3: GoTo PROC_ERR
intOutputFile = FreeFile
Open strOutTmpFile For Binary As intOutputFile
For intCount = 0 To mcintWindowSize
aintWindowPrev(intCount) = mcintNull
abytWindow(intCount) = &H20
Next
CopyMemory aintWindowNext(0), aintWindowPrev(0), (mcintWindowSize + 1) * 2
CopyMemory aintWindowNext(mcintWindowSize + 1), aintWindowPrev(0), mcintWindowSize * 2
CopyMemory abytWindow(mcintWindowSize + 1), abytWindow(0), mcintMaxMatchLen - 1
intByteCodeWritten = 1
lngFileLength = LOF(intInputFile)
lngInBufLen = &HA000&
lngOutBufLen = &HA000&
If lngInBufLen > lngFileLength Then lngInBufLen = lngFileLength
ReDim abytInputBuffer(lngInBufLen - 1)
ReDim abytOutputBuffer(lngOutBufLen + 17)
With udtFileH
.HeaderSize = Len(udtFileH)
lngCurWritten = .HeaderSize + 1
.HeaderTag = mcstrSignature
.FileLength = lngFileLength
.Version = App.Revision
.Flag = 0
End With
intMaxLen = mcintMaxMatchLen
lngBytesRead = mcintMaxMatchLen
lngInPos = mcintMaxMatchLen
intBitCount = 1
Put intOutputFile, , udtFileH
Get intInputFile, , abytInputBuffer
CopyMemory abytWindow(0), abytInputBuffer(0), mcintMaxMatchLen
CopyMemory abytWindow(mcintWindowSize), abytInputBuffer(0), mcintMaxMatchLen
Do While intMaxLen
intMatchPos = 0
intMatchLen = 0
intPrev = aintWindowNext(((&H100& * abytWindow(intBufferLocation + 1) + abytWindow(intBufferLocation)) And &HFFF) + mcintWindowSize + 1)
intCount = 0
Do Until intCount > mintCompressLevel Or intPrev = mcintNull
intNext = 0
Do While (abytWindow(intPrev + intNext) = abytWindow(intBufferLocation + intNext)) And intNext < mcintMaxMatchLen
intNext = intNext + 1
Loop
If intNext > intMatchLen Then
intMatchLen = intNext
intMatchPos = intPrev
If intNext = mcintMaxMatchLen Then
aintWindowNext(aintWindowPrev(intPrev)) = aintWindowNext(intPrev)
aintWindowPrev(aintWindowNext(intPrev)) = aintWindowPrev(intPrev)
aintWindowNext(intPrev) = mcintNull
aintWindowPrev(intPrev) = mcintNull
Exit Do
End If
End If
intPrev = aintWindowNext(intPrev)
intCount = intCount + 1
Loop
If intBitCount And &H100 Then
lngOutPos = intByteCodeWritten
If intByteCodeWritten > lngOutBufLen Then
Put intOutputFile, lngCurWritten, abytOutputBuffer
DoEvents
If m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERR
lngCurWritten = lngCurWritten + intByteCodeWritten
lngOutPos = 0
End If
intByteCodeWritten = lngOutPos + 1
intBitCount = 1
abytOutputBuffer(lngOutPos) = 0
End If
If intMatchLen < mcintMinMatchLen Then
intMatchLen = 1
abytOutputBuffer(intByteCodeWritten) = abytWindow(intBufferLocation)
abytOutputBuffer(lngOutPos) = abytOutputBuffer(lngOutPos) Or intBitCount
End If
If intMatchLen > 1 Then
If intMatchLen > intMaxLen Then intMatchLen = intMaxLen
abytOutputBuffer(intByteCodeWritten) = intMatchPos And &HFF
intByteCodeWritten = intByteCodeWritten + 1
abytOutputBuffer(intByteCodeWritten) = (((intMatchPos / 16) And &HF0) Or intMatchLen - mcintMinMatchLen) And &HFF
End If
intByteCodeWritten = intByteCodeWritten + 1
intBitCount = intBitCount * 2
Do While intMatchLen
intPrev = intBufferLocation + mcintMaxMatchLen
intNext = intPrev And &HFFF
If aintWindowPrev(intNext) <> mcintNull Then
aintWindowNext(aintWindowPrev(intNext)) = aintWindowNext(intNext)
aintWindowPrev(aintWindowNext(intNext)) = aintWindowPrev(intNext)
aintWindowNext(intNext) = mcintNull
aintWindowPrev(intNext) = mcintNull
End If
If lngInPos < lngInBufLen Then
abytWindow(intNext) = abytInputBuffer(lngInPos)
If intPrev >= mcintWindowSize Then abytWindow(intPrev) = abytInputBuffer(lngInPos)
lngBytesRead = lngBytesRead + 1
lngInPos = lngInPos + 1
If lngInPos >= lngInBufLen Then
If lngFileLength > lngBytesRead Then
If lngInBufLen > lngFileLength - lngBytesRead Then
lngInBufLen = lngFileLength - lngBytesRead
ReDim abytInputBuffer(lngInBufLen - 1)
End If
Get intInputFile, , abytInputBuffer
lngInPos = 0
RaiseEvent FileProgress(lngBytesRead / lngFileLength)
DoEvents
If m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERR
End If
End If
End If
intPrev = ((&H100& * abytWindow(intBufferLocation + 1) + abytWindow(intBufferLocation)) And &HFFF) + mcintWindowSize + 1
intNext = aintWindowNext(intPrev)
aintWindowPrev(intBufferLocation) = intPrev
aintWindowNext(intBufferLocation) = intNext
aintWindowNext(intPrev) = intBufferLocation
If intNext <> mcintNull Then aintWindowPrev(intNext) = intBufferLocation
intBufferLocation = (intBufferLocation + 1) And &HFFF
intMatchLen = intMatchLen - 1
Loop
If lngInPos >= lngInBufLen Then intMaxLen = intMaxLen - 1
Loop
If intByteCodeWritten > 0 Then
ReDim Preserve abytOutputBuffer(intByteCodeWritten - 1)
Put intOutputFile, lngCurWritten, abytOutputBuffer
End If
Close intInputFile
Close intOutputFile
If Len(Dir(m_strOutputFileName)) > 0 Then Kill m_strOutputFileName
Name strOutTmpFile As m_strOutputFileName
RaiseEvent FileProgress(1)
Exit Sub
PROC_ERR:
Close intOutputFile
Close intInputFile
If Len(Dir(strOutTmpFile)) > 0 And Len(strOutTmpFile) > 0 Then Kill strOutTmpFile
If intErrNo = 0 Then intErrNo = 255
RaiseEvent ProcssError(LastError(intErrNo))
End Sub
Private Sub Decompress()
Dim intTemp As Integer
Dim intBufferLocation As Integer
Dim intLength As Integer
Dim bytHiByte As Integer
Dim bytLoByte As Integer
Dim intWindowPosition As Integer
Dim lngFlags As Long
Dim intInputFile As Integer
Dim intOutputFile As Integer
Dim abytWindow(mcintWindowSize + mcintMaxMatchLen) As Byte
Dim strOutTmpFile As String
Dim lngBytesRead As Long
Dim lngBytesWritten As Long
Dim lngFileLength As Long
Dim lngOriginalFileLen As Long
Dim lngInBufLen As Long, abytInBuf() As Byte, abytOutBuf() As Byte
Dim lngOutBufLen As Long, lngInPos As Long, lngOutPos As Long
Dim udtFileH As FileHeader
Dim intErrNo As Integer
On Error GoTo PROC_ERR
m_bEnableProcss = True
If Len(Dir(m_strInputFileName)) = 0 Or Len(m_strInputFileName) = 0 Then intErrNo = 4: GoTo PROC_ERR
If Len(m_strOutputFileName) = 0 Then m_strOutputFileName = m_strInputFileName
strOutTmpFile = m_strOutputFileName & ".tmp"
If Len(Dir(strOutTmpFile)) > 0 Then Kill strOutTmpFile
intInputFile = FreeFile
Open m_strInputFileName For Binary Access Read As intInputFile
lngFileLength = LOF(intInputFile)
Get intInputFile, , udtFileH
If udtFileH.HeaderTag = mcstrSignature And udtFileH.Version <= App.Revision Then
Seek #intInputFile, udtFileH.HeaderSize + 1
intOutputFile = FreeFile
Open strOutTmpFile For Binary As intOutputFile
lngOriginalFileLen = udtFileH.FileLength
lngFileLength = lngFileLength - udtFileH.HeaderSize
lngInBufLen = &H20000
lngOutBufLen = &H20000
If lngInBufLen > lngFileLength Then lngInBufLen = lngFileLength
ReDim abytInBuf(lngInBufLen - 1)
ReDim abytOutBuf(lngOutBufLen - 1)
Get intInputFile, , abytInBuf
Do While lngBytesWritten < lngOriginalFileLen
lngFlags = lngFlags / 2
If (lngFlags And &H100) = 0 Then
lngFlags = &HFF00& Or abytInBuf(lngInPos)
lngBytesRead = lngBytesRead + 1
lngInPos = lngInPos + 1
If lngInPos >= lngInBufLen Then
If lngFileLength > lngBytesRead Then
If lngInBufLen > lngFileLength - lngBytesRead Then
lngInBufLen = lngFileLength - lngBytesRead
ReDim abytInBuf(lngInBufLen - 1)
End If
Get intInputFile, , abytInBuf
DoEvents
If m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERR
lngInPos = 0