classzip.cls

VB写的文件压缩算法

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClassZip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
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
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 Let InputFileName(ByVal strValue As String)
    m_strInputFileName = strValue
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

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 abytOutputBuffer(17) As Byte
    Dim intByteCodeWritten As Integer
    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 lngInBufLen As Long, abytInBuf() As Byte, abytOutBuf() 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 = lngInBufLen
            If lngInBufLen > lngFileLength Then lngInBufLen = lngFileLength
            ReDim abytInBuf(lngInBufLen - 1)
            ReDim abytOutBuf(lngOutBufLen - 1)
            With udtFileH
                .HeaderSize = Len(udtFileH)
                .HeaderTag = mcstrSignature
                .FileLength = lngFileLength
                .Version = App.Revision
                .Flag = 0
            End With
            intMaxLen = mcintMaxMatchLen
            lngBytesRead = mcintMaxMatchLen
            lngInPos = mcintMaxMatchLen
            intBitCount = 1
            Put intOutputFile, , udtFileH
            Get intInputFile, , abytInBuf
            CopyMemory abytWindow(0), abytInBuf(0), mcintMaxMatchLen
            CopyMemory abytWindow(mcintWindowSize), abytInBuf(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 intMatchLen > intMaxLen Then intMatchLen = intMaxLen
                        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
                    intCount = 0
                    Do While intCount < intByteCodeWritten
                        abytOutBuf(lngOutPos) = abytOutputBuffer(intCount)
                        intCount = intCount + 1
                        lngOutPos = lngOutPos + 1
                        If lngOutPos >= lngOutBufLen Then
                            Put intOutputFile, , abytOutBuf
                            lngOutPos = 0
                        End If
                    Loop
                    intByteCodeWritten = 1
                    intBitCount = 1
                    abytOutputBuffer(0) = 0
                End If
                If intMatchLen < mcintMinMatchLen Then
                    intMatchLen = 1
                    abytOutputBuffer(intByteCodeWritten) = abytWindow(intBufferLocation)
                    abytOutputBuffer(0) = abytOutputBuffer(0) Or intBitCount
                Else
                    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 Not (aintWindowPrev(intNext) And mcintNull) Then