Login | Register   
LinkedIn
Google+
Twitter
RSS Feed
Download our iPhone app
TODAY'S HEADLINES  |   ARTICLE ARCHIVE  |   FORUMS  |   TIP BANK
Browse DevX
Sign up for e-mail newsletters from DevX


Tip of the Day
Language: VB4/32,VB5,VB6
Expertise: Advanced
Jan 6, 2001

RLECompress - Compress a block of memory using RLE algorithm

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

Francesco Balena
 
Comment and Contribute

 

 

 

 

 


(Maximum characters: 1200). You have 1200 characters left.

 

 

Sitemap
Thanks for your registration, follow us on our social networks to keep up-to-date