一個優化後的壓縮算法（上）

這是一個在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