An optimized compression algorithm (upper)

Algorithm | compression | optimization

This is a compression algorithm code that has been discussed in the CSDN forum.

Compress zip comparisons with WinRAR in the quickest way,
255M of files
Level=0 time 24.98 seconds size 95.1M
level=255 time 30.24 seconds size 91.6M

WinRAR fastest compressed zip 25.2 seconds size 58.6M
Standard RAR compression, I looked, really too slow, also did not try, it is estimated that a few minutes before there will be results.

From the speed, basically flat, this algorithm although the maximum compression capacity is limited, but the sense of design is very clever, each time based on dynamic table, so that software can be done very small, resource consumption is very small. Very worthy of collection!

' Test the code in the form
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) & "seconds"
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) & "seconds"
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 = "Compression"
Command2.Caption = "Decompression"
Command3.caption = "Break"
End Sub

Private Sub form_unload (Cancel as Integer)
Set Objzip = Nothing
End Sub

Private Sub objzip_fileprogress (sngpercentage as single)
Label1 = Int (Sngpercentage *) & "%"
End Sub

Private Sub Objzip_procsserror (errordescription as String)
MsgBox errordescription
End Sub

' Declarations and attributes, methods, events in the Classzip class

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 = "The file to be compressed is not set or does not exist"
Case 2
LastError = "Compressed file length too small"
Case 3
LastError = "Compressed file is being compressed"
Case 4
LastError = "The file to extract is not set or does not exist"
Case 5
LastError = "Uncompressed file format is not available or can not be recognized for the software of other high version software compression"
Case 254
LastError = "User canceled action"
Case 255
LastError = "Unknown error"
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