VB:Tutorials:BNK and RLE

From GDWiki

Contents 1 The ExtractData for RLE 2 The RLE Module: 3 The new mnuFileAdd_Click sub 4 New constants

Saving BMP files to a custom resource file, may lead to a very large file. That's because all the pixels in a BMP are saved, but why should we? Why not use a simple compression like RLE. This algorithm will replace a long line of the same characters. And because the background of a tile or picture has mostly all the same bytes (in 256) we can use this well. Let's say you have a file:

BMPINFO
COLOURTABLE
BLABLA
 
BMPDATA:
AAAAAAAAAABAAAAAAAAAA

A simple one line bmp file of 21 pixels, now when you would use RLE it would become for example:

BMPINFO
COLOURTABLE
BLABLA
 
BMPDATA:
A*10BA*10

WOW! your file is now 20 bytes smaller, of course I know that isn't much, but this is also a small file.

I've added this compression method to Ryan's BNK resource program. And the average ratio is 20%! That saves much space. BUT, there's one disadvantage, the compression is REALLY slow on large files, so we can't use tilesets.

Now the source: I've added a extra ExtractData sub, because we are going to extract normal .bmp files, and our own resource file, including an extra long. Why? We need to save the size of the BMPData after the compression, we cannot calculate it anymore, doh!

[edit] The ExtractData for RLE

Sub ExtractData_RLE(strFileName As String, lngOffset As Long)
 
Dim intBMPFile As Integer
Dim lngBMPData As Long
Dim i As Integer
 
    'Init variables
    Erase gudtBMPInfo.bmiColors
 
    'Open the bitmap
    intBMPFile = FreeFile()
    Open strFileName For Binary Access Read Lock Write As intBMPFile
        'Fill the File Header structure
        Get intBMPFile, lngOffset, gudtBMPFileHeader
        'Fill the Info structure
        Get intBMPFile, , gudtBMPInfo.bmiHeader
        If gudtBMPInfo.bmiHeader.biClrUsed <> 0 Then
            For i = 0 To gudtBMPInfo.bmiHeader.biClrUsed - 1
                Get intBMPFile, , gudtBMPInfo.bmiColors(i).rgbBlue
                Get intBMPFile, , gudtBMPInfo.bmiColors(i).rgbGreen
                Get intBMPFile, , gudtBMPInfo.bmiColors(i).rgbRed
                Get intBMPFile, , gudtBMPInfo.bmiColors(i).rgbReserved
            Next i
        Else
            Get intBMPFile, , gudtBMPInfo.bmiColors
        End If
        'How long is our compressed BMPData array?
        Get intBMPFile, , lngBMPData
        'Size the BMPData array
        ReDim gudtBMPData(lngBMPData)
        'ReDim gudtBMPData(FileSize(gudtBMPInfo.bmiHeader.biWidth, 
gudtBMPInfo.bmiHeader.biHeight))
        'Fill the BMPData array
        Get intBMPFile, , gudtBMPData
        'Ensure info is correct
        gudtBMPFileHeader.bfOffBits = 1078
        gudtBMPInfo.bmiHeader.biSizeImage = FileSize(gudtBMPInfo.bmiHeader.biWidth, 
gudtBMPInfo.bmiHeader.biHeight)
        gudtBMPInfo.bmiHeader.biClrUsed = 0
        gudtBMPInfo.bmiHeader.biClrImportant = 0
        gudtBMPInfo.bmiHeader.biXPelsPerMeter = 0
        gudtBMPInfo.bmiHeader.biYPelsPerMeter = 0
    Close intBMPFile
 
    Call RLE.DeCompress_RLE(gudtBMPData)
 
End Sub

As you can see I didn't change much

[edit] The RLE Module:

Option Explicit
 
Public Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, source As Any, 
ByVal Length As Long)
 
Public OriginalSize As Long             'size of the original file
Public NewSize As Long                  'size after decryption
Public WorkArray() As Byte              'array to store the results

'Compress file
Public Sub Compress_RLE(ByteArray() As Byte)
    OriginalSize = UBound(ByteArray) + 1
    Dim OutStream() As Byte
    Dim FileLong As Long
    Dim X As Long
    Dim Char As Byte
    Dim OldChar As Integer
    Dim RLE_Count As Integer
    Dim OutPos As Long
 
    FileLong = UBound(ByteArray)
    ReDim OutStream(FileLong)       'worst case
    OutPos = 0
    OldChar = -1
    RLE_Count = 0
    For X = 0 To FileLong
        Char = ByteArray(X)
        If Char = OldChar Then
            RLE_Count = RLE_Count + 1
            If RLE_Count < 4 Then
                Call AddCharToArray(OutStream, OutPos, Char)
            End If
            If RLE_Count = 256 Then
                Call AddCharToArray(OutStream, OutPos, CByte(RLE_Count - 3))
                RLE_Count = 0
                OldChar = -1
            End If
        Else
            If RLE_Count > 2 Then
                Call AddCharToArray(OutStream, OutPos, CByte(RLE_Count - 3))
            End If
            Call AddCharToArray(OutStream, OutPos, Char)
            RLE_Count = 1
            OldChar = Char
        End If
    Next
    If RLE_Count > 2 Then
        Call AddCharToArray(OutStream, OutPos, CByte(RLE_Count - 3))
    End If
    OutPos = OutPos - 1
    ReDim ByteArray(OutPos)
    NewSize = OutPos + 1
    Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub
 
'DeCompress file
Public Sub DeCompress_RLE(ByteArray() As Byte)
    NewSize = UBound(ByteArray) + 1
    Dim OutStream() As Byte
    Dim FileLong As Long
    Dim X As Long
    Dim Y As Integer
    Dim RRun1 As Boolean
    Dim RRun2 As Boolean
    Dim Char As Byte
    Dim OldChar As Integer
    Dim RLE_Count As Byte
    Dim OutPos As Long
    OutPos = 0
    ReDim OutStream(UBound(ByteArray))
    RRun1 = False
    RRun2 = False
    OldChar = -1
    For X = 0 To UBound(ByteArray)
        If RRun1 = True Then
            If RRun2 = True Then
                RLE_Count = ByteArray(X)
                For Y = 1 To RLE_Count
                    Call AddCharToArray(OutStream, OutPos, Char)
                Next
                RRun1 = False
                RRun2 = False
                OldChar = -1
            Else
                Char = ByteArray(X)
                Call AddCharToArray(OutStream, OutPos, Char)
                If Char = OldChar Then
                    RRun2 = True
                Else
                    RRun1 = False
                End If
                OldChar = Char
            End If
        Else
            Char = ByteArray(X)
            Call AddCharToArray(OutStream, OutPos, Char)
            If Char = OldChar Then RRun1 = True
            OldChar = Char
        End If
    Next
    OutPos = OutPos - 1
    ReDim ByteArray(OutPos)
    OriginalSize = OutPos + 1
    Call CopyMem(ByteArray(0), OutStream(0), OutPos + 1)
End Sub
 
'this sub will add a char into the outputstream
Private Sub AddCharToArray(ToArray() As Byte, ToPos As Long, Char As Byte)
    If ToPos > UBound(ToArray) Then
        ReDim Preserve ToArray(ToPos + 500)
    End If
    ToArray(ToPos) = Char
    ToPos = ToPos + 1
End Sub

[edit] The new mnuFileAdd_Click sub

Private Sub mnuFileAdd_Click()
 
Dim lngTemp As Long
Dim strPath As String
Dim strFileList As String
Dim strFiles() As String
Dim i As Integer
 
    'If there is no "current" file, then make a new one first
    If gstrFileName = "" Then
    MsgBox "Open/create a BNK file first!"
    Exit Sub
    End If
 
    'Add a bitmap to the bank file
    cmdDialog.FileName = ""
    cmdDialog.Flags = HideReadOnly Or FileMustExist Or AllowMultiSelect Or LongNames Or Explorer
    cmdDialog.Filter = "Bitmap Files (*.bmp)|*.bmp"
    cmdDialog.DialogTitle = "Select one/more BMP file(s)"
    On Error Resume Next
    cmdDialog.ShowOpen
    'If the user canceled out of the dialog, exit sub
    If Err.Number = cdlCancel Or cmdDialog.FileName = "" Then
        Exit Sub
    End If
    On Error GoTo 0
    'Handle multiple selection
    ReDim strFiles(0)
    strPath = ""
    If InStr(1, cmdDialog.FileName, Chr(0)) > 0 Then
        strPath = Left(cmdDialog.FileName, InStr(1, cmdDialog.FileName, Chr(0)) - 1) & "\"
        cmdDialog.FileName = Right(cmdDialog.FileName, Len(cmdDialog.FileName) - InStr(1, 
cmdDialog.FileName, Chr(0)))
    End If
    cmdDialog.InitDir = strPath
    'Extract the filenames from the selection
    strFileList = cmdDialog.FileName & Chr(0)
    strFiles(0) = Left(strFileList, InStr(1, strFileList, Chr(0)) - 1)
    strFileList = Right(strFileList, Len(strFileList) - InStr(1, strFileList, Chr(0)))
    Do While InStr(1, strFileList, Chr(0))
        ReDim Preserve strFiles(UBound(strFiles) + 1)
        strFiles(UBound(strFiles)) = Left(strFileList, InStr(1, strFileList, Chr(0)) - 1)
        strFileList = Right(strFileList, Len(strFileList) - InStr(1, strFileList, Chr(0)))
    Loop
 
    'Place the data in the resource
    Open gstrFileName For Binary Access Read Write Lock Write As #1
    'Loop through each selected file
    For i = 0 To UBound(strFiles)
        'Extract the bitmap data
        ExtractData strPath & strFiles(i)
        Get 1, 1, lngTemp
        'If this file is empty, init the footer
        If lngTemp = 5 Then
            ReDim gudtFooter.lngFileLocation(0)
            ReDim gudtFooter.strFileName(0)
        'Otherwise just add to the end
        Else
            ReDim Preserve gudtFooter.lngFileLocation(UBound(gudtFooter.lngFileLocation) + 1)
            ReDim Preserve gudtFooter.strFileName(UBound(gudtFooter.strFileName) + 1)
        End If
        'Place the data
        gudtFooter.lngFileLocation(UBound(gudtFooter.lngFileLocation)) = lngTemp
        gudtFooter.strFileName(UBound(gudtFooter.strFileName)) = ExtractFilename(strFiles(i))
        Put 1, lngTemp, gudtBMPFileHeader
        Put 1, , gudtBMPInfo
        Call RLE.Compress_RLE(gudtBMPData)
        Put 1, , UBound(gudtBMPData)
        Put 1, , gudtBMPData
        lngTemp = Seek(1)
        Put 1, , gudtFooter
        Put 1, 1, lngTemp
    Next i
    Close #1
 
    'Update the display
    UpdateDisplay
 
End Sub

As you might see, I've changed the OpenFile stuff, It now has long file names and the XP look, if you have XP. I didn't test this on Windows version older than XP

[edit] New constants

Global Const HideReadOnly = &H4         'Common Dialog Constants
Global Const OverWritePrompt = &H2
Global Const FileMustExist = &H1000
Global Const AllowMultiSelect = &H200
Public Const LongNames = &H200000
Public Const Explorer = &H80000

I hope you can do something with this tutorial! I've also added some extra stuff, It's all in the source.

Source

Marv