• Home
 · 
• Files/File Controls/Input/Output
 · 
• RLE : Run Length Encoding on files

RLE : Run Length Encoding on files

RLE : Run Length Encoding on files

Rate RLE : Run Length Encoding on files

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

'RLE
'Run Length Encoding module
'Made by Julien Lecomte
'[email protected]
'http://thunder.prohosting.com/~jagsite
'Feel free to modify for personal use
'Feel free to distribute
'Don't take credit for what you didn't create.
'
'
'Format of Compressed File
'[1] = Size of Original FileName (byte)
'[x] = Original FileName
'[1] = File Attributes (byte)
'[4] = Size of original file (dword)
'[x] = data block
'
'RLE data block
'[2] = Header (word)
'[x] = FileData
'
'*******************************************************************************************
'Compress
'Input:  sFileInputName = Path of file to encode
'        sFileOutputName = Path of output file
'Output: True for success
Public Function Compress(ByVal sFileInputName As String, ByVal sFileOutputName As String) As Boolean
    Const iDataCompressed As Integer = &HF000
    Dim byLengthOfTitle   As Byte
    Dim byFileAttributes  As Byte
    Dim byBufferFirst     As Byte
    Dim byBufferLast      As Byte
    Dim iBufferData%
    Dim sFileTitle$
    Dim lFileSize&
    Dim lFileInputPointer&
    Dim lFileInputNumber&
    Dim lFileOutputPointer&
    Dim lFileOutputNumber&
    
On Error Resume Next
    Kill sFileOutputName

On Error GoTo ErrCompress
    'Get File Title
    sFileTitle = StrReverse(sFileInputName)
    byLengthOfTitle = InStr(1, sFileTitle, "\", vbTextCompare) - 1
    sFileTitle = Right$(sFileInputName, byLengthOfTitle)
    
    'Get attributes and size
    byFileAttributes = GetAttr(sFileInputName)
    lFileSize = FileLen(sFileInputName)
    
    'Open files
    lFileInputNumber = FreeFile
    Open sFileInputName For Binary Access Read As lFileInputNumber
    lFileOutputNumber = FreeFile
    Open sFileOutputName For Binary Access Write As lFileOutputNumber

    'Store Header
    Put lFileOutputNumber, , byLengthOfTitle
    Put lFileOutputNumber, , sFileTitle
    Put lFileOutputNumber, , byFileAttributes
    Put lFileOutputNumber, , lFileSize
    
    'Read file and analyze
    lFileInputPointer = 0
    lFileOutputPointer = Seek(lFileOutputNumber)
    Do
        Get lFileInputNumber, , byBufferFirst
        Get lFileInputNumber, , byBufferLast
        
        If byBufferFirst = byBufferLast Then
            'Compression
            iBufferData = iDataCompressed + 1
            
            Do
                iBufferData = iBufferData + 1
                Get lFileInputNumber, , byBufferLast
            Loop While byBufferLast = byBufferFirst And Not ( _
                       iBufferData = &HFFFF Or _
                       Seek(lFileInputNumber) >= lFileSize)
            
            Put lFileOutputNumber, , iBufferData
            Put lFileOutputNumber, , byBufferFirst
            
            lFileInputPointer = Seek(lFileInputNumber) - 1
            Seek lFileInputNumber, lFileInputPointer
            
        Else
            'No Compression
            iBufferData = 0
            lFileOutputPointer = Seek(lFileOutputNumber)
            Put lFileOutputNumber, , iBufferData
            Do
                iBufferData = iBufferData + 1
                Put lFileOutputNumber, , byBufferFirst
                byBufferFirst = byBufferLast
                Get lFileInputNumber, , byBufferLast
            Loop Until byBufferLast = byBufferFirst Or _
                       iBufferData = &HEFFF Or _
                       Seek(lFileInputNumber) >= lFileSize
                       
            'Correct error if EOF
            If EOF(lFileInputNumber) Then ' Seek(lFileInputNumber) >= lFileSize Then
                iBufferData = iBufferData + 1
                lFileInputPointer = Seek(lFileInputNumber)
                Seek lFileInputNumber, lFileSize
                Get lFileInputNumber, , byBufferLast
                Put lFileOutputNumber, , byBufferLast
                Seek lFileInputNumber, lFileInputPointer
            End If
            
            Seek lFileOutputNumber, lFileOutputPointer
            Put lFileOutputNumber, , iBufferData
            
            lFileOutputPointer = LOF(lFileOutputNumber) + 1
            Seek lFileOutputNumber, lFileOutputPointer

            lFileInputPointer = Seek(lFileInputNumber) - 2
            Seek lFileInputNumber, lFileInputPointer

        End If
    Loop Until Seek(lFileInputNumber) >= lFileSize
    
    Close lFileInputNumber
    Close lFileOutputNumber
    Compress = True
Exit Function
ErrCompress:
On Error Resume Next
    Close lFileInputNumber
    Close lFileOutputNumber
    Compress = False
End Function

'*******************************************************************************************
'GetCompressedFileAttrib
'Input:  sFileCompressedName = Path of compressed file
'        spFileTitle = pointer to string title of file
'        bypFileAttributes = pointer to byte attributes of file
'        lpFileSize = pointer to long file size
'Output: Length of sFileTitle
Public Function GetCompressedFileAttrib(ByVal sFileCompressedName As String, ByRef spFileTitle As String, ByRef bypFileAttributes As Byte, ByRef lpFileSize As Long) As Long
    Dim byLengthOfTitle   As Byte
    Dim byFileAttributes  As Byte
    Dim sFileTitle$
    Dim lFileSize&
    Dim lFileCompressedPointer&
    Dim lFileCompressedNumber&

On Error GoTo ErrGetCompressedFileAttrib
    
    'Open files
    lFileCompressedNumber = FreeFile
    Open sFileCompressedName For Binary Access Read As lFileCompressedNumber

    'Store Header
    Get lFileCompressedNumber, , byLengthOfTitle
    sFileTitle = Space$(byLengthOfTitle)
    Get lFileCompressedNumber, , sFileTitle
    Get lFileCompressedNumber, , byFileAttributes
    Get lFileCompressedNumber, , lFileSize
    
    GetCompressedFileAttrib = byLengthOfTitle
    spFileTitle = sFileTitle
    bypFileAttributes = byFileAttributes
    lpFileSize = lFileSize
    
    Exit Function
ErrGetCompressedFileAttrib:
On Error Resume Next
    Close lFileCompressedNumber
End Function


'*******************************************************************************************
'Decompress
'Input:  sFileInputName = Path of file to deencode
'        sFileOutputName = Path of output file
'Output: True for success
Public Function Decompress(ByVal sFileInputName As String, ByVal sFileOutputName As String) As Boolean
    Const iDataCompressed As Integer = &HF000
    Dim byLengthOfTitle   As Byte
    Dim byFileAttributes  As Byte
    Dim byBuffer          As Byte
    Dim iCompressCounter%
    Dim iCompressCounterTo%
    Dim iBufferData%
    Dim sFileTitle$
    Dim lFileSize&
'    Dim lFileInputPointer&
    Dim lFileInputNumber&
'    Dim lFileOutputPointer&
    Dim lFileOutputNumber&
    
'On Error GoTo ErrDecompress
    'Open files
    lFileInputNumber = FreeFile
    Open sFileInputName For Binary Access Read As lFileInputNumber
    lFileOutputNumber = FreeFile
    Open sFileOutputName For Binary Access Write As lFileOutputNumber

    'Store Header
    Get lFileInputNumber, , byLengthOfTitle
    sFileTitle = Space$(byLengthOfTitle)
    Get lFileInputNumber, , sFileTitle
    Get lFileInputNumber, , byFileAttributes
    Get lFileInputNumber, , lFileSize
    
    'Read file and analyze
    Do
        Get lFileInputNumber, , iBufferData
        
        If iBufferData And iDataCompressed Then
            iCompressCounterTo = (iBufferData - iDataCompressed)
            Get lFileInputNumber, , byBuffer
            For iCompressCounter = 1 To iCompressCounterTo
                Put lFileOutputNumber, , byBuffer
            Next
        Else
            For iCompressCounter = 1 To iBufferData
                Get lFileInputNumber, , byBuffer
                Put lFileOutputNumber, , byBuffer
            Next
        End If
    Loop Until EOF(lFileInputNumber)
    
    Close lFileInputNumber
    Close lFileOutputNumber
    Decompress = True
Exit Function
ErrDecompress:
On Error Resume Next
    Close lFileInputNumber
    Close lFileOutputNumber
    Decompress = False
End Function