lzw3.bas

LZW数据压缩算法

Attribute VB_Name = "LZW"
Option Explicit
' -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
'|          LZW - Compression/Uncompression            |
'|-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-|
'|Author: Asgeir B. Ingvarsson <[e-mail]>       |
'|Modified by: Aldo Vargas <[e-mail]>|
'|-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-|
'|For any comments or questions, please contact        |
'|the writer/modifier of this code.                    |
'|-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-|
'|This code will sometimes not yield a very high       |
'|compression ratio, due to 9-bit code-words.          |
'|If you use this code or modify it, I would appreciate|
'|it if you would mention my name somewhere and send me|
'|a copy of the code (if it has been modified).        |
'|-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-|
'|LZW is property of Unisys and is free for            |
'|noncommercial software.                              |
'|(The decoding function is free)                      |
' -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

Private Dict(0 To 511) As String
Private Count As Integer
Private cont()

Private Sub Init()
'Here we fill our dictionary with all ASCII values
'so that we have some code-words to start with.
  Dim i As Integer
  For i = 0 To 255
      Dict(i) = Chr(i)
  Next
End Sub

Private Function Search(inp As String) As Integer
'This function will search our dictionary and return
'the code-word for the best match.
  Dim i As Integer, c As Integer
  If Len(inp) = 1 Then
    Search = Asc(inp)
  Else
    For i = 258 To Count - 1 'ASCII 256 & 257 are reserved
        If Dict(i) = inp Then Search = i: Exit Function
    Next
    Search = 512
  End If
End Function

Private Function Add(inp As String) As Boolean
'This function will add a string to our dictionary,
'if the dictionary is full the function is set to false
  Add = False
  If Count = 512 Then Wipe: Add = True 'Dictionary is full
  Dict(Count) = inp
  Count = Count + 1
End Function

Private Sub Wipe()
'Here we reset our dictionary
  Dim i As Integer
  For i = 256 To 511
      Dict(i) = ""
  Next
  Count = 258 'So we start out right
End Sub

Public Function Deflate(ByVal inp As String) As String
  Dim i As Long, j As Long, length As Long
  Dim p As String, c As String, temp As String, o As String
  Init
  Wipe
  p = ""
  i = 1
  
  ReDim cont(0 To (Len(inp) + 3)) 'so we don't get buffer overflow
  
  Do Until i > Len(inp)
      c = Mid(inp, i, 1)
      i = i + 1
  
      temp = p & c
      If Not Search(temp) = 512 Then
          p = temp
      Else
          length = length + 1
          cont(length) = Search(p)
          'Here we make sure that when we wipe our dictionary, the decoder does the same
          If Add(temp) = True Then length = length + 1: cont(length) = 256
          p = c
      End If
  Loop
  cont(0) = 256
  cont(length + 1) = Search(p)
  cont(length + 2) = 257
  cont(length + 3) = 0

  o = Eight_Bit(cont(), length + 3)
  Deflate = Mid(o, 2) 'Since all strings will start with chr(0), we skip it.
                      'If we want to be compatible with the GIF standard then we
                      'keep this chr(0) and of course don't add one whilst decoding
End Function

Public Function Inflate(ByVal inp As String) As String
  Dim length As Long, cw As Long, o As String, i As Long, pw As Long, p As String, c As String
  Init
  Wipe
  inp = Chr(0) & inp 'So we don't get mixed up
  length = Nine_Bit(inp)
  If Not cont(0) = 256 Then Exit Function
  cw = cont(1)
  o = Dict(cw)
  i = 2
  
  Do Until i > length
      pw = cw
      cw = cont(i)
      i = i + 1
  
      If cw = 256 Then Wipe: GoTo bottom
      If cw = 257 Then GoTo done
      If Not Dict(cw) = "" Then
          o = o & Dict(cw)
          p = Dict(pw)
          c = Mid(Dict(cw), 1, 1)
          Add (p & c)
      ElseIf Dict(cw) = "" Then
          p = Dict(pw)
          c = Mid(Dict(pw), 1, 1)
          o = o & p & c
          Add (p & c)
      End If
bottom:
  Loop
done:
  Inflate = o
End Function

Private Function Eight_Bit(inp(), length As Long) As String
  Dim i As Long, c As Long
  Dim bits As String, bitstream As String, stream As String
  bitstream = Space((length + 1) * 9)
  For i = 0 To length
      Mid(bitstream, (length - i) * 9 + 1, 9) = Format(Encode(inp(i)), "000000000")
  Next
  
  stream = Space((Len(bitstream) \ 8) + 1)
  For i = (Len(bitstream) - 7) To 1 Step -8
      bits = Mid(bitstream, i, 8)
      c = c + 1
      Mid(stream, c, 1) = Chr(Decode(bits))
  Next
  bits = "1" & Mid(bitstream, 1, 7)
  Mid(stream, Len(stream), 1) = Chr(Decode(bits))
  Eight_Bit = Mid(stream, 1, Len(stream) - 1)
End Function

Private Function Nine_Bit(inp As String) As Long
  Dim i As Long, j As Long, o As String, h As String, inpLen As Long
  inpLen = Len(inp)
  o = Space(inpLen * 8)
  For i = 1 To inpLen
     Mid(o, (inpLen - i) * 8 + 1, 8) = Encode(Asc(Mid(inp, i, 1)))
  Next
  ReDim cont(0 To (Len(inp) - 2))
  j = 0
  For i = (Len(o) - 8) To 1 Step -9
      h = Mid(o, i, 9)
      cont(j) = Decode(h)
      j = j + 1
  Next
  Nine_Bit = Len(inp) - 2
End Function

Private Function Encode(ByVal inp As Long) As String
  Dim DecValue As Long, BinValue As String, TempValue As Long
  DecValue = inp
  Do
      TempValue = DecValue Mod 2
      BinValue = CStr(TempValue) & BinValue
      DecValue = DecValue \ 2
  Loop Until DecValue = 0
  BinValue = Format(BinValue, "00000000")
  Encode = BinValue
End Function

Private Function Decode(ByVal inp As String) As Long
  Dim o As Long, i As Long, inpLen As Long
  inpLen = Len(inp)
  For i = 1 To inpLen
      If Mid(inp, i, 1) = "1" Then
          o = o + 2 ^ (inpLen - i)
      End If
  Next
  Decode = o
End Function