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:	extfile.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 = TrueEnd Function