dcsimg
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

By submitting your information, you agree that devx.com may send you DevX offers via email, phone and text message, as well as email offers about other products and services that DevX believes may be of interest to you. DevX will process your information in accordance with the Quinstreet Privacy Policy.


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

WEBINAR:

On-Demand

Building the Right Environment to Support AI, Machine Learning and Deep Learning


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