by Julien Lecomte (4 Submissions)
Category: Files/File Controls/Input/Output
Compatability: Visual Basic 5.0
Difficulty: Unknown Difficulty
Originally Published: Sat 6th May 2000
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
RLE : Run Length Encoding on files
VBcoders
'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
