上一篇
下一篇
用VB写的压缩算法(慢)
作者:JiaJia 日期:2008-06-08
引用内容顶级专家用VB写的压缩算法居然比C++编写的WinRar压缩算法慢100倍,
该代码是一位俄罗斯专家写的,极具收藏价值和实用价值,只可惜速度慢了一些.
现附源代码供大家学习和收藏,同时也请各位高手对源代码分析, 看看能不能进行一些优化. 请大家把优化后的测试结果贴出来供其他人学习和讨论.
测试程序:
Dim ObjZip as New ClassZip
ObjZip.InputFileName = "C:\1\Test.Bmp"
ObjZip.InputFileName = "C:\1\Test.Zip"
ObjZip.Compress
....
=====================================
下面是 ClassZip的全部源代码
======================================
Optional explicit
Public Event FileProgress(sngPercentage As Single)
Private m_strInputFileName As String
Private m_strOutputFileName As String
Private mintInputFile As Integer
Private mintOutputFile As Integer
Private Const mcintWindowSize As Integer = &H1000
Private Const mcintMaxMatchLen As Integer = 18
Private Const mcintMinMatchLen As Integer = 3
Private Const mcintNull As Integer = &H1000
Private Const mcintByteNotify As Integer = &H1000
Private mabytWindow(mcintWindowSize + mcintMaxMatchLen) As Byte
Private maintWindowNext(mcintWindowSize + 1 + mcintWindowSize) As Integer
Private maintWindowPrev(mcintWindowSize + 1) As Integer
Private mintMatchPos As Integer
Private mintMatchLen As Integer
' *******************************************
' This is for writing the bytes out to a file
' *******************************************
Private mabytOutputBuffer(17) As Byte
Private mbytByteCodeWritten As Byte
Private mbytBitCount As Byte
' LZ signature
Private Const mcstrSignature As String = "FMSLZ1"
Public Property Get InputFileName() As String
' Returns the input file name
InputFileName = m_strInputFileName
End Property
Public Property Let InputFileName(ByVal strValue As String)
'strValue: Set the input file name
m_strInputFileName = strValue
End Property
Public Property Get OutputFileName() As String
'Returns the output file name
OutputFileName = m_strOutputFileName
End Property
Public Property Let OutputFileName(ByVal strValue As String)
'strValue: Set the output file name
m_strOutputFileName = strValue
End Property
Public Sub Compress()
'***********************************************************
'This procedure compresses the input file to the output file
'***********************************************************
Dim intBufferLocation As Integer
Dim intMaxLen As Integer
Dim bytByte As Byte
Dim lngBytesRead As Long
Dim lngFileLength As Long
On Error GoTo PROC_ERR
' Get the next free file id
mintInputFile = FreeFile
'Openz the input file
Open m_strInputFileName For Binary Access Read As mintInputFile
'Try to delete the output file. If it doesn't exist an error is raised
On Error Resume Next
Kill m_strOutputFileName
On Error GoTo PROC_ERR
' Get the next free file id
mintOutputFile = FreeFile
' Open the output file
Open m_strOutputFileName For Binary As mintOutputFile
' Initialize the search buffers
CompressionInitialize
intBufferLocation = 0
intMaxLen = 0
lngFileLength = LOF(mintInputFile)
' write header
Put mintOutputFile, , mcstrSignature
Put mintOutputFile, , lngFileLength
' Prefill the end of the buffer with the first characters in the file
Do While (intMaxLen < mcintMaxMatchLen) And Not EOF(mintInputFile)
Get mintInputFile, , bytByte
mabytWindow(intMaxLen) = bytByte
mabytWindow(intMaxLen + mcintWindowSize) = mabytWindow(intMaxLen)
intMaxLen = intMaxLen + 1
lngBytesRead = lngBytesRead + 1
Loop
' While there is a match in the buffer
Do While (intMaxLen)
' Find the next match
FindMatch (intBufferLocation)
If (mintMatchLen > intMaxLen) Then
mintMatchLen = intMaxLen
End If
' -> If the match is less than the minimum length, just write out the byte
If (mintMatchLen < mcintMinMatchLen) Then
mintMatchLen = 1
WriteByte mabytWindow(intBufferLocation)
Else
WriteEntry mintMatchPos, mintMatchLen
End If
' Update the window for each character in the match
Do While (mintMatchLen > 0)
' Remove the current position from the search tables
DeletePosition ((intBufferLocation + mcintMaxMatchLen) And (mcintWindowSize - 1))
intMaxLen = intMaxLen - 1
If Not EOF(mintInputFile) Then
Get mintInputFile, , bytByte
' Update the window
mabytWindow((intBufferLocation + mcintMaxMatchLen) And (mcintWindowSize - 1)) = bytByte
' Special handling for updating the end of the buffer
If (intBufferLocation + mcintMaxMatchLen >= mcintWindowSize) Then
mabytWindow(intBufferLocation + mcintMaxMatchLen) = bytByte
End If
lngBytesRead = lngBytesRead + 1
intMaxLen = intMaxLen + 1
End If
' Update the search tables
InsertPosition (intBufferLocation)
intBufferLocation = (intBufferLocation + 1) And (mcintWindowSize - 1)
mintMatchLen = mintMatchLen - 1
' Raise the progress event
If (lngBytesRead Mod mcintByteNotify) = 0 Then
RaiseEvent FileProgress(lngBytesRead / lngFileLength)
End If
Loop
' Raise the progress event
If (lngBytesRead Mod mcintByteNotify) = 0 Then
RaiseEvent FileProgress(lngBytesRead / lngFileLength)
End If
Loop
' Finish writing the output file
WriteFinish
RaiseEvent FileProgress(1)
' Close the files we opened
Close mintOutputFile
Close mintInputFile
U_ext:
Exit Sub
' if error show message box
PROC_ERR:
MsgBox "Error: Compress", vbCritical, "ULZ"
Resume U_ext
End Sub
'-----
Public Sub Decompress()
'*************************************************************
'This procedure decompresses the input file to the output file
'*************************************************************
Dim intCounter As Integer
Dim bytHiByte As Byte
Dim intBufferLocation As Integer
Dim bytLoByte As Byte
Dim bytLength As Byte
Dim intWindowPosition As Integer
Dim bytByte As Byte
Dim intFlags As Integer
Dim lngBytesRead As Long
Dim lngBytesWritten As Long
Dim strSignature As String * 6
Dim lngOriginalFileLen As Long
On Error GoTo PROC_ERR
' Get the next free file id
mintInputFile = FreeFile
' Open the input file
Open m_strInputFileName For Binary Access Read As mintInputFile
' Try to delete the output file. If it doesn't exist an error is raised
On Error Resume Next
Kill m_strOutputFileName
On Error GoTo PROC_ERR
' Get the next free file id
mintOutputFile = FreeFile
' Open the output file
Open m_strOutputFileName For Binary As mintOutputFile
' get header
Get mintInputFile, , strSignature
Get mintInputFile, , lngOriginalFileLen
' Check the signature to see if this file is compressed
If strSignature = mcstrSignature Then
' While there is still data to decompress
Do While lngBytesWritten < lngOriginalFileLen
intFlags = Shri(intFlags, 1)
' If the flag byte has been processed, get the next one
If (intFlags And 256) = 0 Then
Get mintInputFile, , bytByte
lngBytesRead = lngBytesRead + 1
intFlags = LongToInt(CLng(bytByte) Or &HFF00&)
End If
' If this byte is not compressed
If (intFlags And 1) Then
' Read from the input and write to the output
Get mintInputFile, , bytByte
lngBytesRead = lngBytesRead + 1
Put mintOutputFile, , bytByte
lngBytesWritten = lngBytesWritten + 1
' Update the window
mabytWindow(intWindowPosition) = bytByte
intWindowPosition = intWindowPosition + 1
intWindowPosition = intWindowPosition And (mcintWindowSize - 1)
Else
' This byte is compressed
' Get the window position and length of the match
Get mintInputFile, , bytHiByte
lngBytesRead = lngBytesRead + 1
Get mintInputFile, , bytLoByte
lngBytesRead = lngBytesRead + 1
intBufferLocation = BufPosition(bytHiByte, bytLoByte)
bytLength = BufLength(bytLoByte)
intCounter = 0
' Read the data from the window and write to the output
Do While intCounter < bytLength
bytByte = mabytWindow((intBufferLocation + intCounter) And (mcintWindowSize - 1))
Put mintOutputFile, , bytByte
lngBytesWritten = lngBytesWritten + 1
mabytWindow(intWindowPosition) = bytByte
intWindowPosition = intWindowPosition + 1
intWindowPosition = intWindowPosition And (mcintWindowSize - 1)
intCounter = intCounter + 1
' Raise the progress event
If (lngBytesWritten Mod mcintByteNotify) = 0 Then
RaiseEvent FileProgress(lngBytesWritten / lngOriginalFileLen)
End If
Loop
End If
' Raise the progress event
If (lngBytesWritten Mod mcintByteNotify) = 0 Then
RaiseEvent FileProgress(lngBytesWritten / lngOriginalFileLen)
End If
Loop
RaiseEvent FileProgress(1)
End If
' Close the files we opened
Close mintOutputFile
Close mintInputFile
U_ext:
Exit Sub
PROC_ERR:
MsgBox "Error: Decompress", vbCritical, "ULZ"
Resume U_ext
End Sub
Private Sub BitSetByte(bytNumber As Byte, bytBitNumber As Byte)
'*********************************************
' This procedure sets a bit in a byte variable
'*********************************************
' Parameterz:
'bytNumber - The byte variable to set the bit in. The result is also returned
' in this parameter
'bytBitNumber - The bit number to clear
On Error GoTo PROC_ERR
bytNumber = bytNumber Or Shlb(1, bytBitNumber)
U_ext:
Exit Sub
PROC_ERR:
MsgBox "Error: Bit Set Byte", vbCritical, "ULZ"
Resume U_ext
End Sub
Private Function BufLength(bytLoByte As Byte) As Byte
'********************************************
'This function returns the length of an entry
'********************************************
' Parameterz
' bytLoByte - The low byte of the entry
' Returnz the length of the entry
On Error GoTo PROC_ERR
BufLength = (bytLoByte And &HF) + mcintMinMatchLen
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: Buffeer Leghth", , vbCritical, "ULZ"
Resume U_ext
End Function
Private Function BufPosition(bytHiByte As Byte, bytLoByte As Byte) As Integer
'******************************************************
' This function returns the window position of an entry
'******************************************************
' bytHiByte - The high byte of the entry
' bytLoByte - The low byte of the entry
' Returnz : The position of the entry
Dim intPosition As Integer
' if error then show message
On Error GoTo PROC_ERR
intPosition = Shli(bytLoByte And &HF0, 4) + bytHiByte
intPosition = intPosition And &HFFF
BufPosition = intPosition
U_ext:
' exit
Exit Function
PROC_ERR:
' error message
MsgBox "Error: Buffer Position", vbCritical, "ULZ"
Resume U_ext
End Function
Private Sub CompressionInitialize()
' **************************************************************************
' This procedure initializes the module variables for the compression and
' decompression routines
' **************************************************************************
Dim intCounter As Integer
On Error GoTo PROC_ERR
' Initialize the window to spaces
For intCounter = 0 To mcintWindowSize + mcintMaxMatchLen - 1
mabytWindow(intCounter) = Asc(" ")
Next intCounter
For intCounter = 0 To mcintWindowSize + mcintWindowSize
maintWindowNext(intCounter) = mcintNull
Next intCounter
For intCounter = 0 To mcintWindowSize
maintWindowPrev(intCounter) = mcintNull
Next intCounter
'Reset write buffer
mabytOutputBuffer(0) = 0
mbytByteCodeWritten = 1
mbytBitCount = 0
U_ext:
' exit
Exit Sub
PROC_ERR:
' error message
MsgBox "Error: Initialize", vbCritical, "ULZ"
Resume U_ext
End Sub
'-----
Private Function dblToLong(ByVal dblNumber As Double) As Long
' *****************************************************************************
' This routine does an unsigned conversion from a double Value to a long Value.
' This procedure correctly handles any double value
' *****************************************************************************
'Parameterz
' dblNumber - the double value to convert to a long
' long returnz
Dim dblDivisor As Double
Dim dblTemp As Double
On Error GoTo PROC_ERR
' Visual basic does not allow you enter the value &H100000000 directly,
' so we enter &H7FFFFFFF, double it and add two to create it.
dblDivisor = &H7FFFFFFF
dblDivisor = (dblDivisor * 2) + 2
'if the number is larger than a long can store, then truncate it
If dblNumber > dblDivisor Or dblNumber < 0 Then
dblTemp = dblNumber - (Int(dblNumber / dblDivisor) * dblDivisor)
Else
dblTemp = dblNumber
End If
' if the number is greater than a signed long, convert it to a negative
If dblTemp > &H7FFFFFFF Then
dblToLong = dblTemp - dblDivisor
ElseIf dblTemp < 0 Then
' If the number is negative
dblToLong = dblDivisor + dblTemp
Else
dblToLong = dblTemp
End If
U_ext:
'exit
Exit Function
PROC_ERR:
MsgBox "Error: dbltoLong", vbExclamation, "ULZ"
Resume U_ext
End Function
Private Sub DeletePosition(intCurBufIndex As Integer)
' **************************************************
' This procedure removes a character from the window
' **************************************************
' Parameterz:
' intCurBufIndex - The index of the byte in the window to delete
Dim intNext As Integer
Dim intPrev As Integer
On Error GoTo PROC_ERR
' If this position has been previously assigned
If (maintWindowPrev(intCurBufIndex) <> mcintNull) Then
' Update the next character array with the previous value
intPrev = maintWindowPrev(intCurBufIndex)
intNext = maintWindowNext(intCurBufIndex)
maintWindowNext(intPrev) = intNext
maintWindowPrev(intNext) = intPrev
maintWindowNext(intCurBufIndex) = mcintNull
maintWindowPrev(intCurBufIndex) = mcintNull
End If
U_ext:
Exit Sub
PROC_ERR:
MsgBox "Error: DeletePosition", vbExclamation, "ULZ"
Resume U_ext
End Sub
Private Sub FindMatch(intCurBufIndex As Integer)
' *************************************************
' This procedure searches for a match in the window
' *************************************************
' intCurBufIndex - The current position in the window
Dim intPos As Integer
Dim intKey As Integer
Dim intCounter As Integer
On Error GoTo PROC_ERR
mintMatchPos = 0
mintMatchLen = mintMatchPos
'calculate position
intKey = (mabytWindow(intCurBufIndex) + Shli(mabytWindow(intCurBufIndex + 1), 8) And &HFFF&) + mcintWindowSize + 1
' If we have encountered this two letter combination before, intPos will hold
' the position at which we last last encountered it
intPos = maintWindowNext(intKey)
intCounter = 0
Do While (intPos <> mcintNull) And (intCounter <> mcintMaxMatchLen)
'Find a match in the window
intCounter = 0
Do While intCounter < mcintMaxMatchLen And mabytWindow(intPos + intCounter) = mabytWindow(intCurBufIndex + intCounter)
intCounter = intCounter + 1
Loop
' If this is the best match so far, keep track of it
If (intCounter > mintMatchLen) Then
mintMatchLen = intCounter
mintMatchPos = (intPos) And (mcintWindowSize - 1)
End If
' Retrieve the next index into the window
intPos = maintWindowNext(intPos)
Loop
If (intCounter = mcintMaxMatchLen) Then
DeletePosition (intPos)
End If
U_ext:
Exit Sub
PROC_ERR:
MsgBox "Error: FindMatch", vbCritical, "ULZ"
Resume U_ext
End Sub
Private Function HiByte(ByVal intNumber As Integer) As Byte
' *******************************************
' Returns the high byte of the passed integer
' *******************************************
' intNumber - integer to return the high byte of
' Return the byte
On Error GoTo PROC_ERR
HiByte = Int((IntToLong(intNumber) / &H100&)) And &HFF&
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: HiByte", vbCritical, "ULZ"
Resume U_ext
End Function
Private Function HiWord(lngNumber As Long) As Integer
' *******************************************
' Returns the high integer of the passed long
' *******************************************
' lngNumber - long value to return the high integer of
' Return the integer
On Error GoTo PROC_ERR
HiWord = LongToInt(Int((lngNumber / &H10000)))
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: HiWord", vbCritical, "ULZ"
Resume U_ext
End Function
Private Sub InsertPosition(intCurBufIndex As Integer)
' **************************************************
' This procedure inserts a character into the window
' **************************************************
' intCurBufIndex - The index of the byte in the window to insert
' What the function returns or 'Nothing'
Dim intNextChar As Integer
Dim intKey As Integer
On Error GoTo PROC_ERR
' Calculate hash key based on the current byte and the next byte
intKey = (mabytWindow(intCurBufIndex) + Shli(mabytWindow(intCurBufIndex + 1), 8) And &HFFF&) + mcintWindowSize + 1
'Get the last position pointed to by this key
intNextChar = maintWindowNext(intKey)
' Set the position in the lookup buffer to the current position in the window
maintWindowNext(intKey) = intCurBufIndex
' keep track of the last position pointed to by this key
maintWindowPrev(intCurBufIndex) = intKey
' point the current position in the next window to the key position in the next
' buffer
maintWindowNext(intCurBufIndex) = intNextChar
' If there was a previous character
If (intNextChar <> mcintNull) Then
maintWindowPrev(intNextChar) = intCurBufIndex
End If
U_ext:
Exit Sub
PROC_ERR:
MsgBox "Error: InsertPosition", vbCritical, "ULZ"
Resume U_ext
End Sub
Private Function IntToByte(ByVal intNumber As Integer) As Byte
' ************************************************************************
' This routine does an unsigned conversion from an integer value to a byte
' value. This procedure correctly handles any integer value
' ************************************************************************
' intNumber - the integer value to convert to a byte
' return the Byte
On Error GoTo PROC_ERR
IntToByte = intNumber And &HFF&
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: IntToByte", vbCritical, "ULZ"
Resume U_ext
End Function
Private Function IntToLong(ByVal intNumber As Integer) As Long
' ****************************************************************************
' This routine converts an integer value to a long value, treating the integer
' as unsigned
' ****************************************************************************
' Parameters: intNumber - the integer to convert to long
' retiurn the long
On Error GoTo PROC_ERR
' This routine converts an integer value to a long value
If intNumber < 0 Then
IntToLong = intNumber + &H10000
Else
IntToLong = intNumber
End If
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: IntToLong", vbCritical, "ULZ"
Resume U_ext
End Function
Private Function LoByte(ByVal intNumber As Integer) As Byte
' ******************************************
' Returns the low byte of the passed integer
' ******************************************
' intNumber - integer to return the low byte of
' rEturn the byte
On Error GoTo PROC_ERR
LoByte = intNumber And &HFF&
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: LoByte"
Resume U_ext
End Function
'-------
Private Function LongToInt(ByVal lngNumber As Long) As Integer
' ******************************************************************************
' This routine does an unsigned conversion from a long value to an integer value.
' This procedure correctly handles any long value
' ******************************************************************************
' lngNumber - the long value to convert to an integer
' returnz the Integer
On Error GoTo PROC_ERR
' This routine converts a long value to an integer
lngNumber = lngNumber And &HFFFF&
If lngNumber > &H7FFF Then
LongToInt = lngNumber - &H10000
Else
LongToInt = lngNumber
End If
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: LongToInt", vbCritical, "ULZ"
Resume U_ext
End Function
Private Function LoWord(ByVal lngNumber As Long) As Integer
' ******************************************
' Returns the low integer of the passed long
' ******************************************
' lngNumber - long to return the low integer of
' Returnz the integer
On Error GoTo PROC_ERR
LoWord = LongToInt(lngNumber And &HFFFF&)
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: LoWord", vbCritical, "ULZ"
Resume U_ext
End Function
Private Function Shlb(ByVal bytValue As Byte, ByVal bytPlaces As Byte) As Byte
' ********************************************************
' Shifts a numeric value left the specified number of bits.
' *********************************************************
' bytValue - byte value to shift
' bytPlaces - number of places to shift
' Returnz the Shifted value
Dim lngMultiplier As Long
On Error GoTo PROC_ERR
' if we are shifting 8 or more bits, then the result is always zero
If bytPlaces >= 8 Then
Shlb = 0
Else
lngMultiplier = 2 ^ bytPlaces
Shlb = IntToByte(LongToInt(bytValue * lngMultiplier))
End If
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: Shlb", vbCritical, "ULZ kewl"
Resume U_ext
End Function
Private Function Shli(ByVal intValue As Integer, ByVal bytPlaces As Byte) As Integer
' **********************************************************************************
' Shifts a numeric value left the specified number of bits. Left shifting can be
' defined as a multiplication operation. For the number of bits we want to shift a
' value to the left, we need to raise two to that power, then multiply the result by
' our original value.
' **********************************************************************************
' intValue - integer value to shift
' bytPlaces - number of places to shift
' reeturn Shifted value
Dim lngMultiplier As Long
On Error GoTo PROC_ERR
' if we are shifting 16 or more bits, then the result is always zero
If bytPlaces >= 16 Then
Shli = 0
Else
lngMultiplier = 2 ^ bytPlaces
Shli = LongToInt(intValue * lngMultiplier)
End If
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: Shli", vbCritical, "ULZ"
Resume U_ext
End Function
Private Function Shll(ByVal lngNumber As Long, ByVal bytPlaces As Byte) As Long
' *********************************************************
' Shifts a numeric Value left the specified number of bits.
' *********************************************************
' lngNumber - long Value to shift
' bytPlaces - number of places to shift
' Returnz the Shifted Value
Dim dblMultiplier As Double
On Error GoTo PROC_ERR
' if we are shifting 32 or more bits, then the result is always zero
If bytPlaces >= 32 Then
Shll = 0
Else
dblMultiplier = 2 ^ bytPlaces
Shll = dblToLong(lngNumber * dblMultiplier)
End If
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: Shll", vbCritical, "ULZ"
Resume U_ext
End Function
Private Sub WriteBufferByte(abytOutput() As Byte, lngBytesWritten As Long, bytValue As Byte)
' ********************************************************
' This procedure writes a single byte to the output buffer
' ********************************************************
' abytOutput - The output buffer
' lngBytesWritten - The current position in the output buffer
' bytByte - The byte to write to the buffer
Dim intCounter As Integer
On Error GoTo PROC_ERR
' If eight bytes have been written, write the output buffer
If mbytBitCount = 8 Then
For intCounter = 0 To mbytByteCodeWritten - 1
abytOutput(lngBytesWritten) = mabytOutputBuffer(intCounter)
lngBytesWritten = lngBytesWritten + 1
Next intCounter
' Reset the write variables
mbytByteCodeWritten = 1
mbytBitCount = 0
mabytOutputBuffer(0) = 0
End If
' Update the output buffer
mabytOutputBuffer(mbytByteCodeWritten) = bytValue
' Increment the number of bytes written
mbytByteCodeWritten = mbytByteCodeWritten + 1
' Indicate that this byte is not compressed
BitSetByte mabytOutputBuffer(0), mbytBitCount
'Increment the number of entries written
mbytBitCount = mbytBitCount + 1
U_ext:
'exit
Exit Sub
PROC_ERR:
' error message
MsgBox "Error: WriteBufferByte", vbCritical, "Huffman"
Resume U_ext
End Sub
Private Function Shri(ByVal lngValue As Long, ByVal bytPlaces As Byte) As Integer
' *******************************************************
' Shifts a long Value right the selected number of places
' *******************************************************
' lngValue - integer Value to shift
' bytPlaces - number of places to shift
' Returnz the Shifted value
Dim lngDivisor As Long
On Error GoTo PROC_ERR
' if we are shifting 16 or more bits, then the result is always zero
If bytPlaces >= 16 Then
Shri = 0
Else
lngDivisor = 2 ^ bytPlaces
Shri = Int(IntToLong(lngValue) / lngDivisor)
End If
U_ext:
Exit Function
PROC_ERR:
MsgBox "Error: Shri", vbCritical, "ULZ"
Resume U_ext
End Function
Private Sub WriteBufferEntry(abytOutput() As Byte, lngBytesWritten As Long, intPos As Integer, intLen As Integer)
'*********************************************************
'this procedure writes a window entry to the output buffer
'*********************************************************
' Parameterz:
' abytOutput - The output buffer
' lngBytesWritten - The current position in the output buffer
' intPos - The position of the entry
' intLen - The length of the entry
Dim intCounter As Integer
On Error GoTo PROC_ERR
' If eight bytes have been written, write the output buffer
If mbytBitCount = 8 Then
For intCounter = 0 To mbytByteCodeWritten - 1
abytOutput(lngBytesWritten) = mabytOutputBuffer(intCounter)
lngBytesWritten = lngBytesWritten + 1
Next intCounter
' Reset the output varables
mbytByteCodeWritten = 1
mbytBitCount = 0
mabytOutputBuffer(0) = 0
End If
' The first byte contains the loword of the position in the window
mabytOutputBuffer(mbytByteCodeWritten) = IntToByte(intPos)
' Increment the number of bytes written
mbytByteCodeWritten = mbytByteCodeWritten + 1
' The second byte of an entry contains the 4 hi bits of the position, and the
' lower four bits contain the length of the match
mabytOutputBuffer(mbytByteCodeWritten) = IntToByte(((Shri(intPos, 4) And &HF0&) Or intLen - mcintMinMatchLen))
' Increment the number of bytes written
mbytByteCodeWritten = mbytByteCodeWritten + 1
' Increment the number of entries written
mbytBitCount = mbytBitCount + 1
U_ext:
'exit the procedure
Exit Sub
PROC_ERR:
' errror message
MsgBox "Error: WriteBufferEntry", vbCritical, "ULZ"
Resume U_ext
End Sub
文章来自: 
引用通告: 
Tags: 评论: 1 | 引用: 0 | 查看次数: -
回复
kid[2008-09-04 04:07 PM | 
]发表评论