Binaryworld - RLECompress - Compress a block of memory using RLE algorithm ... [ VB -> Arrays ]

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _
  Any, source As Any, ByVal Bytes As Long)

' compress a block of memory (a string, an array, a bitmap)
' using the RLE compression algorithm
'
' Returns True if the block has been compressed,
'     False if the compression would create a block larger
'        then the original data
'
' ADDRESS is the start address of the memory block to compress
'     use StrPtr(s) for strings, use VarPtr(arr(0)) for arrays
' BYTES is the size of the memory block
'     use LenB(s) for strings, use N * LenB(arr(0)) for arrays
' OUTBUFFER() is an array of bytes that, on exit, will contain the
'     compressed form of the memory block
' ITEMSIZE is a suggestion to the routine, and should match the expected
'     size of the repeated pattern.Can be 1,2,4,8
'     Use 1 for ANSI strings, Byte arrays, 256-colors bitmaps
'     Use 2 for Unicode strings, Integer arrays, 64K-color bitmaps
'     Use 4 for Long and Single arrays
'     Use 8 for Double and Currency arrays
' Note: BYTES must be an integer multiple of this ITEMSIZE
'
' Example:
'  Dim s As String, b() As Byte
'  Open "c:\textfile.txt" For Input As #1
'  ' we are sure that this is an ANSI string
'  s = StrConv(Input(LOF(1), 1), vbFromUnicode)
'  Close #1
'  ' convert this ANSI string
'  RLECompress StrPtr(s), LenB(s), b(), 1
'
'  ' decompress the data
'  Dim o() As Byte, res As String
'  RLEUncompress VarPtr(b(0)), UBound(b) + 1, o()
'  ' reconvert from ANSI to Unicode
'  res = StrConv(o(), vbUnicode)

Function RLECompress(ByVal address As Long, ByVal Bytes As Long, _
  outBuffer() As Byte, Optional ByVal ItemSize As Integer = 2) As Boolean
  ' itemSize can be 1,2,4,8
  If ItemSize <> 1 And ItemSize <> 2 And ItemSize <> 4 And ItemSize <> 8 Then
    Err.Raise 5, , "Wrong value for ItemSize"
  End If
  ' Bytes must be a multiple of itemSize
  If (Bytes Mod ItemSize) Then
    Err.Raise 5, , "Bytes must be a multiple of ItemSize"
  End If
  ' the size must be long enough
  If Bytes < 64 Then
    Err.Raise 5, , "Bytes must be > 64"
  End If

  ' prepare the output buffer
  ' initially this is as long as the input stream
  ReDim outBuffer(0 To Bytes - 1) As Byte

  ' we use Currency variables, that can accomodate up to 8 bytes
  ' and are enough fast at comparisons

  Dim i As Long
  Dim outIndex As Long
  Dim prevValue As Currency
  Dim currValue As Currency
  Dim matchCount As Integer

  ' the first value in the output buffer
  ' is a special signature
  CopyMemory outBuffer(0), &HABCD, 2
  ' the second value is the ItemSize
  CopyMemory outBuffer(2), ItemSize, 2
  ' the next dword is the length of the input buffer
  CopyMemory outBuffer(4), Bytes, 4

  ' move the first value to the outbuffer as-is
  CopyMemory prevValue, ByVal address, ItemSize
  address = address + ItemSize
  CopyMemory outBuffer(8), prevValue, ItemSize
  outIndex = 8 + ItemSize

  ' analyze each item in the input stream
  For i = 2 To Bytes \ ItemSize
    ' get the next value
    CopyMemory currValue, ByVal address, ItemSize
    address = address + ItemSize

    If prevValue <> currValue Then
      ' execute this block when the new value differs
      ' and when matchCount is about to overflow
      If matchCount Then
        ' exit if the compressed image isn't shorter than the original
        If outIndex + 2 >= Bytes Then Exit Function
        ' if there were matching values, write the count
        CopyMemory outBuffer(outIndex), matchCount, 2
        outIndex = outIndex + ItemSize
        ' reset matchCount
        matchCount = 0
      End If
      ' exit if the compressed image isn't shorter than the original
      If outIndex + ItemSize >= Bytes Then Exit Function
      ' copy the new value to the output buffer
      CopyMemory outBuffer(outIndex), currValue, ItemSize
      outIndex = outIndex + ItemSize
      ' now we have a new prevValue
      prevValue = currValue
    ElseIf matchCount = 0 Then
      ' this value is the same as the previous one
      ' and this is the second equal value in a sequence
      ' exit if the compressed image isn't shorter than the original
      If outIndex + ItemSize >= Bytes Then Exit Function
      ' write the new value
      CopyMemory outBuffer(outIndex), currValue, ItemSize
      outIndex = outIndex + ItemSize
      ' initialize matchCount
      matchCount = 2
    ElseIf matchCount = 32767 Then
      ' we must output the counter before it overflows
      ' exit if the compressed image isn't shorter than the original
      If outIndex + 2 >= Bytes Then Exit Function
      ' if there were matching values, write the count
      CopyMemory outBuffer(outIndex), matchCount, 2
      outIndex = outIndex + ItemSize
      ' reset matchCount
      matchCount = 2
    Else
      ' just increment matchCount
      matchCount = matchCount + 1
    End If
  Next

  ' if we get here, the input buffer has been completely compressed
  ' but we must account for pending matches
  If matchCount Then
    ' exit if the compressed image isn't shorter than the original
    If outIndex + 2 >= Bytes Then Exit Function
    ' if there were matching values, write the count
    CopyMemory outBuffer(outIndex), matchCount, 2
    outIndex = outIndex + ItemSize
  End If

  ' shrink the output buffer
  ReDim Preserve outBuffer(0 To outIndex - 1) As Byte

  ' return True to signal that the compression was successful
  RLECompress = True

End Function