算法|压缩|优化 

'类中压缩与解压算法

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