VB压缩技术

最新推荐文章于 2022-01-02 16:09:20 发布

godwiser

最新推荐文章于 2022-01-02 16:09:20 发布

阅读量1.3k

点赞数

文章标签： vb integer command string byte kill

这几天正研究文件压缩解压缩，这是在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