The Lempel-Ziv-Welch (LZW) algorithm provides loss-less data compression.

You can read a complete description of it in the   Wikipedia article   on the subject.   It was patented, but it entered the public domain in 2004.




 
    Function compress(str as String) As String
      Dim i as integer
      Dim w as String = ""
      Dim c as String
      Dim strLen as Integer
      Dim wc as string
      Dim dic() as string
      Dim result() as string
      Dim lookup as integer
      Dim startPos as integer = 0
      Dim combined as String
 
      strLen = len(str)
 
      dic = populateDictionary
 
      for i = 1 to strLen
        c = str.mid(i, 1)
        wc = w + c
 
        startPos = getStartPos(wc)
 
        lookup = findArrayPos(dic, wc, startPos)
        if (lookup <> -1) then
          w = wc
        Else
          startPos = getStartPos(w)
          lookup = findArrayPos(dic, w, startPos)
          if lookup <> -1 then
            result.Append(lookup.ToText)
          end if
          dic.append(wc)
          w = c
        end if
      next i
 
      if (w <> "") then
        startPos = getStartPos(w)
        lookup = findArrayPos(dic, w, startPos)
        result.Append(lookup.ToText)
      end if
 
      return join(result, ",")
    End Function
 
    Function decompress(str as string) As string
      dim comStr() as string
      dim w as string
      dim result as string
      dim comStrLen as integer
      dim entry as string
      dim dic() as string
      dim i as integer
 
      comStr = str.Split(",")
      comStrLen = comStr.Ubound
      dic = populateDictionary
 
      w = chr(val(comStr(0)))
      result = w
      for i = 1 to comStrLen
        entry = dic(val(comStr(i)))
        result = result + entry
        dic.append(w + entry.mid(1,1))
        w = entry
      next i
 
      return result
    End Function
 
    Private Function findArrayPos(arr() as String, search as String, start as integer) As Integer
      dim arraySize as Integer
      dim arrayPosition as Integer = -1
      dim i as Integer
 
      arraySize = UBound(arr)
 
      for i = start to arraySize
        if (strcomp(arr(i), search, 0) = 0) then
          arrayPosition = i
          exit
        end if
      next i
 
      return arrayPosition
    End Function
 
    Private Function getStartPos(str as String) As integer
      if (len(str) = 1) then
        return 0
      else
        return 255
      end if
    End Function
 
    Private Function populateDictionary() As string()
      dim dic() as string
      dim i as integer
 
      for i = 0 to 255
        dic.append(Chr(i))
      next i
 
      return dic
    End Function
 
 