一個最佳化後的壓縮演算法(上)

來源:互聯網
上載者:User
演算法|壓縮|最佳化  

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




相關文章

E-Commerce Solutions

Leverage the same tools powering the Alibaba Ecosystem

Learn more >

Apsara Conference 2019

The Rise of Data Intelligence, September 25th - 27th, Hangzhou, China

Learn more >

Alibaba Cloud Free Trial

Learn and experience the power of Alibaba Cloud with a free trial worth $300-1200 USD

Learn more >

聯繫我們

該頁面正文內容均來源於網絡整理,並不代表阿里雲官方的觀點,該頁面所提到的產品和服務也與阿里云無關,如果該頁面內容對您造成了困擾,歡迎寫郵件給我們,收到郵件我們將在5個工作日內處理。

如果您發現本社區中有涉嫌抄襲的內容,歡迎發送郵件至: info-contact@alibabacloud.com 進行舉報並提供相關證據,工作人員會在 5 個工作天內聯絡您,一經查實,本站將立刻刪除涉嫌侵權內容。