这是一个在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

|