clszip.cls

纯粹用vb实现的压缩算法

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