VB:Tutorials:BNK and RLE

From GPWiki
(Difference between revisions)
Jump to: navigation, search
m (TOC moved to the top of the page)
 
m (Fixed download link)
 
Line 288: Line 288:
  
 
== New constants ==
 
== New constants ==
−
<code type="vb">
+
<code type="basic">
 
Global Const HideReadOnly = &H4        'Common Dialog Constants
 
Global Const HideReadOnly = &H4        'Common Dialog Constants
 
Global Const OverWritePrompt = &H2
 
Global Const OverWritePrompt = &H2
Line 300: Line 300:
 
I've also added some extra stuff, It's all in the source.
 
I've also added some extra stuff, It's all in the source.
  
−
[[:Files:BNK.zip|Source]]
+
[[:File:BNK.zip|Source]]
  
 
Marv
 
Marv
  
 
[[Category:VB]] [[Category:Tutorial]]
 
[[Category:VB]] [[Category:Tutorial]]

Latest revision as of 13:03, 10 February 2013

Contents


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!


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

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

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

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

Retrieved from "http://content.gpwiki.org/index.php/VB:Tutorials:BNK_and_RLE"
Personal tools
Namespaces
Variants
Actions
Navigation
Toolbox