这几天正研究文件压缩解压缩，这是在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
End If
End If
End If
If (lngFlags And 1) Then
abytWindow(intWindowPosition) = abytInBuf(lngInPos)
abytOutBuf(lngOutPos) = abytInBuf(lngInPos)
lngBytesRead = lngBytesRead + 1
lngInPos = lngInPos + 1
lngBytesWritten = lngBytesWritten + 1
lngOutPos = lngOutPos + 1
intWindowPosition = (intWindowPosition + 1) And &HFFF
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
End If
End If
If lngOutPos >= lngOutBufLen Then
Put intOutputFile, , abytOutBuf
lngOutPos = 0
RaiseEvent FileProgress(lngBytesWritten / lngOriginalFileLen)
DoEvents
If m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERR
End If
Else
bytHiByte = 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
End If
End If
bytLoByte = abytInBuf(lngInPos)
intBufferLocation = ((bytLoByte And &HF0) * 16 + bytHiByte) And &HFFF
intLength = (bytLoByte And &HF) + mcintMinMatchLen
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
End If
End If
intTemp = intBufferLocation + intLength
Do While intBufferLocation < intTemp
abytOutBuf(lngOutPos) = abytWindow((intBufferLocation) And &HFFF)
abytWindow(intWindowPosition) = abytOutBuf(lngOutPos)
intBufferLocation = intBufferLocation + 1
lngBytesWritten = lngBytesWritten + 1
intWindowPosition = (intWindowPosition + 1) And &HFFF
lngOutPos = lngOutPos + 1
If lngOutPos >= lngOutBufLen Then
Put intOutputFile, , abytOutBuf
lngOutPos = 0
RaiseEvent FileProgress(lngBytesWritten / lngOriginalFileLen)
DoEvents
If m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERR
End If
Loop
End If
Loop
If lngOutPos > 0 Then
ReDim Preserve abytOutBuf(lngOutPos - 1)
Put intOutputFile, , abytOutBuf
End If
Close intOutputFile
Else
intErrNo = 5
GoTo PROC_ERR
End If
Close intInputFile
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
摘自：网络整理
★VB部分相关文章推荐：★
☆VB6 中善用ByRef 提升速度
☆[vb] Set 语句
☆VB_Format自定义格式
☆用VB如读取内存地址
☆vb FindwindowEx的用法实例
☆进制转化进10进制数
☆收藏:如何获取当前已经打开的IE对象(VB6代码)
☆DXInput中键码的转换(VB6.0代码)
☆如何在VB6.0里动态使用具有事件的对象
☆[vb]格式输出Format函数
☆读取和写入Windows的INI文件
☆简述UTF－8编码原理及其文本文件的读写技术【转】
☆VB中的文件操作
☆VB中的文件操作文档
☆vb 中拷贝文件
☆VB反跟踪技术点滴
☆VB共享软件防破解设计技术初探（二）
☆VB共享软件防破解设计技术初探（三）
☆VB共享软件防破解设计技术初探（一）
☆RTF文件格式【转】
☆VB压缩技术
☆[vb]FSO对象模型在VB中的应用
☆VB 窗体实现文件拖拽获取路径方法
☆VB：注册表的读写
☆vb中空操作（等待）的指令、延时方法
☆VB让控件可以当标题栏拖动
☆FSO对象新建、打开、保存文件
☆获取网关IP和MAC 的VB源码
☆VB文件关联
☆vb获得本地和远程的MAC地址(网卡地址)
☆VB中ShellExeCute的应用
☆VB打开网址方法大全
☆vb简单控制音量大小及静音的方法
☆拖动无边框窗体(VB6代码)
☆VB使用FileSystemObject对象写文件
☆VB 从注册表中删除项及其某个值
☆vb 字符串转为数字和判断字符串是否是数字字符串【转】
☆vb按热键启动应用程序
☆VB的坐标系统综述
☆VB利用API函数来处理文件
☆关于VB中Shell及ShellExecute的总结与记录
☆[vb]On Error GoTo 0和On Error resume区别
☆[vb]On Error 语句
☆记录一下:在菜单上添加自绘图形的例子(VB6代码)
☆vb中findwindow的疑惑
☆[vb]FindWindow使用方法
☆常用文件类[转，无法运行通，待调试]
☆[vb]url utf-8编码
☆VB中的Unicode 和Ansi 格式
☆VB中的format格式化函数
☆VB中字符串匹配的多种方式
☆VB抓图
☆谈vb目录文件操作的三种方法－2
☆谈vb目录文件操作的三种方法－1
☆vb使用open方法读写文件
☆VB的MD5加密模块
☆VB 超简单的屏幕截图代码
☆vb以类名或窗口标题查找句柄并关闭
☆VB将配置保存到EXE本身（生成EXE木马程序）
☆VB 调用腾讯截图控件CameraDLL.dll
☆在VB6.0中怎么实现escape和unescape
☆vb求任意两线交点
☆VB中调用Windows API的注意事项[VB知识库]
☆VB 一个获得自己外网IP 地址的程序代码
☆VB程序中实现IP地址子网掩码网关DNS的更改[转]
☆在VB 中应用FSO 对象模型介绍（摘自网络）
☆[转] Vb中FSO 对象的介绍
☆VB 画坐标轴
☆VB 二进制文件的操作
☆[VB]BMP转JPG
☆VB中KeyCode常数用法
☆vb实时曲线的绘制和保存
更多精彩>>>
评论