VB调用WinRAR

VB调用WinRAR 与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 Sub ObjZip_FileProgress(sngPercentage As Single) Private 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, pSou rce 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(int BufferLocation)) And &HFFF) + mcintWindowSize + 1) intCount = 0 Do Until intCount > mintCompressLevel Or intPrev = mcintNull intNext = 0 Do While (abytWindow(intPrev + intNext) = abytWindow(intBufferLocation + intNext)) And int Next < 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 - mci ntMinMatchLen) 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)) A nd &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 '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, pSou rce 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 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, pSou rce 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