Yesterday, 01:01 PM
So here are other options for saving to BMP. First, uncompressed 8 bit format (256 colors), then RLE compressed format (256 colors and with the same problem as in RLE4) and then twice 16 bit BMP format (555 and 565). For formats where _LoadImage is not supported, the program always also has a Loader that loads and displays that specific format. I found a slight bug in _LoadImage for the 16bit 555 format (5 bite red, 5 bite green, 5 bite blue), sometimes the colors are not displayed correctly. For this reason, this program also has a Loader that loads and displays the image correctly. I verified that it is indeed the correct implementation using the Windows 10 photo viewer. In the future, I will add a clear program here, where I will merge all the previous programs into one large program and I will deal with the logic before choosing the format and saving BMP. But that's for next time.
So first a simple matter - saving the BMP to an uncompressed 8 bit BMP. An 8 bit source is assumed as the input image:
This also involves saving the 8-bit input image into an RLE compressed 8-bit BMP. If the input image contains multiple single-color areas, the output file size will be significantly reduced. However, if you save a 32-bit photo to this format (which you must first dither to reduce to 256 colors), the input image will be unnecessarily large, and in this case it is better to use an uncompressed format.
The previous program has the same problem as RLE4 with absolute blocks, but it is modified to work.
The following is the 16-bit BMP format. This is an uncompressed format (RLE compression is used for files with a palette, so this is no longer in this case). Three colors use _Unsigned Integer to store one pixel, so 2 bytes and a maximum value of 65535. In this version, 5 bits are used for each color (R,G,B) and one bit is not used. In this version, I discovered a bug in _LoadImage during testing, which supports this format, loads it - but then displays some colors incorrectly. I verified that there is no bug in the program using the Windows photo viewer and another browser, both output files displayed exactly as nicely as the function in the Load16BitBMP555 program. This format is essentially the so-called HiColor mode, which was used in older Windows. The advantage is a better color range than in 8 bits and a third smaller size than in the 24 bit format.
And finally, I have the 16-bit BMP 565 format. This is basically the same as the previous case, only 6bit is used for green, unlike BMP555. This format is not supported by _LoadImage (that wouldn't make sense), the output file size is the same as in the previous case, it's just for fun. Because of the color shift, there's also a loader written here that will display the image correctly, but in this case there's a compatibility problem with other photo viewers, so they'll display the image with distorted colors. As I said, this last program is just for fun.
In the next post, I will explain why I focused on this and also show how to easily use it.
So first a simple matter - saving the BMP to an uncompressed 8 bit BMP. An 8 bit source is assumed as the input image:
Code: (Select All)
'------------------------------------------------------------------------------------------------------
' HlavnÝ program Main program
' - NaŔte 8bit BMP (nebo jinř 8bit obrßzek) - Loads an 8-bit BMP (or another 8-bit image)
' - Ulo×Ý jej jako nekomprimovanř 8bit BMP (BI_RGB) - Saves it as an uncompressed 8-bit BMP (BI_RGB)
'------------------------------------------------------------------------------------------------------
Dim srcImg As Long
srcImg = _LoadImage("panda.png", 256) ' <--- musÝ břt 8bitovř obrßzek <--- must be an 8-bit image here!
If srcImg = -1 Then
Print "Error opening source file." ' Chyba p°i otevÝrßnÝ zdrojovÚho souboru Error opening source file.
End
End If
Print "Saving your image to file output_8bit.bmp (not compressed format)"
' Uklßdßme obrßzek do souboru output_8bit.bmp (nekonprimovanř formßt) Saving the image to file output_8bit.bmp (not compressed format)
Save8BitBMP srcImg, "output_8bit.bmp"
_FreeImage srcImg
Print "Saved. Opening it with _LoadImage..." ' Ulo×eno. OtevÝrßme pomocÝ _LoadImage... Saved. Opening it with _LoadImage...
Sleep 2
Dim i As Long
i = _LoadImage("output_8bit.bmp", 256)
Screen i ' ZobrazÝme obrßzek Display the image
Print "Compatible with _LoadImage." ' KompatibilnÝ s _LoadImage Compatible with _LoadImage.
End
'-------------------------------------------------------------------------------------------------------------------------------------------------
' Ulo×Ý 8bit obrßzek do nekomprimovanÚho BMP (BI_RGB) Saves an 8-bit image as an uncompressed BMP (BI_RGB)
'
' Vstup: Input:
' imgPtr - handle (ukazatel) na raw data obrßzku (W*H bajt¨, top-down) - handle (pointer) to raw image data (W*H bytes, top-down)
' fileName$ - nßzev vřslednÚho BMP souboru - name of the resulting BMP file
'
' Poznßmka: Funkce p°edpoklßdß, ×e obrßzek mß maximßlný 256 barev.
' Raw data se zapÝÜÝ bottom-up a ka×dř °ßdek se zarovnß na 4 bajty. Note: The function assumes the image has a maximum of 256 colors.
' Raw data are written bottom-up and each row is padded to 4 bytes.
'--------------------------------------------------------------------------------------------------------------------------------------------------
Sub Save8BitBMP (imgPtr As Long, fileName As String)
' ZjistÝme rozmýry obrßzku Determine the dimensions of the image
Dim W As Long, H As Long
W = _Width(imgPtr)
H = _Height(imgPtr)
' 1) VypoŔÝtßme °ßdkovou dÚlku v bajtech se zarovnanřm na 4 bajty Calculate the row length in bytes, aligned to 4 bytes.
Dim rowBytes As Long
rowBytes = ((W + 3) \ 4) * 4
' Velikost pixelovřch dat Size of the pixel data
Dim imageSize As Long
imageSize = rowBytes * H
' Celkovß velikost souboru:
' FileHeader (14) + InfoHeader (40) + paleta (256*4 = 1024) + imageSize Total file size:
' FileHeader (14) + InfoHeader (40) + palette (256*4 = 1024) + imageSize
Dim headerSize As Long
headerSize = 14 + 40 + (256 * 4)
Dim fileSize As Long
fileSize = headerSize + imageSize
' 2) SestavÝme BMP hlaviŔky Assemble the BMP headers.
' --- BMP FileHeader (14 bajt¨) --- BMP FileHeader (14 bytes)
Type BMPFileHeader
bfType As String * 2 ' "BM"
bfSize As Long
bfRes1 As Integer
bfRes2 As Integer
bfOffBits As Long
End Type
Dim fh As BMPFileHeader
fh.bfType = "BM"
fh.bfSize = fileSize
fh.bfRes1 = 0
fh.bfRes2 = 0
fh.bfOffBits = headerSize
' --- BMP InfoHeader (40 bytes)
Type BMPInfoHeader
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Dim ih As BMPInfoHeader
ih.biSize = 40
ih.biWidth = W
ih.biHeight = H
ih.biPlanes = 1
ih.biBitCount = 8
ih.biCompression = 0 ' BI_RGB => nekomprimovanř BI_RGB => uncompressed
ih.biSizeImage = imageSize
ih.biXPelsPerMeter = 0
ih.biYPelsPerMeter = 0
ih.biClrUsed = 256
ih.biClrImportant = 256
' 3) Otev°eme soubor pro binßrnÝ zßpis Open the file for binary writing.
If _FileExists(fileName) Then Kill fileName
Open fileName For Binary As #1
' Zßpis FileHeader Write the FileHeader.
Put #1, , fh.bfType
Put #1, , fh.bfSize
Put #1, , fh.bfRes1
Put #1, , fh.bfRes2
Put #1, , fh.bfOffBits
' Zßpis InfoHeader Write the InfoHeader.
Put #1, , ih.biSize
Put #1, , ih.biWidth
Put #1, , ih.biHeight
Put #1, , ih.biPlanes
Put #1, , ih.biBitCount
Put #1, , ih.biCompression
Put #1, , ih.biSizeImage
Put #1, , ih.biXPelsPerMeter
Put #1, , ih.biYPelsPerMeter
Put #1, , ih.biClrUsed
Put #1, , ih.biClrImportant
' 4) Zßpis palety (256 * 4 bajt¨) Write the palette (256 * 4 bytes).
' Formßt: B, G, R, 0 Format: Blue, Green, Red, 0.
Dim i As Long
Dim K As _Unsigned Long
For i = 0 To 255
K = _PaletteColor(i, imgPtr)
' P°Ýmo zapÝÜeme hodnotu K; p°edpoklßdßme, ×e _PaletteColor vracÝ hodnotu
' ve formßtu, kde prvnÝ bajt = Blue, pak Green, pak Red. Directly write the value K; we assume that _PaletteColor returns a value
' in a format where the first byte = Blue, then Green, then Red.
Put #1, , K
Next i
' 5) Zßpis pixelovřch dat Write the pixel data.
' Raw data jsou ulo×ena v pamýti na adrese imgPtr (top-down, bez mezer). Raw data are stored in memory at address imgPtr (top-down, without gaps).
' BMP uklßdß °ßdky bottom-up, proto se zapÝÜou v opaŔnÚm po°adÝ. BMP stores rows bottom-up, so they are written in reverse order.
rowBytes = ((W + 3) \ 4) * 4
Dim rowPadding As Long
rowPadding = rowBytes - W
If rowPadding > 0 Then
padd$ = String$(rowPadding, Chr$(0))
PADD = 1
End If
m$ = Space$(W)
Dim m As _MEM
Dim u As Long
m = _MemImage(imgPtr)
For y = 0 To H - 1
_MemGet m, m.OFFSET + ((H - 1) - y) * W, m$ ' ╚teme °ßdek pixel¨ odspodu nahoru Read a row of pixels from bottom to top
Put #1, , m$
If PADD Then Put #1, , padd$ ' P°idßme zarovnßvacÝ bajty, pokud jsou pot°eba Add padding bytes if needed
Next
Close #1 ' Zav°eme soubor Close the file
End Sub
This also involves saving the 8-bit input image into an RLE compressed 8-bit BMP. If the input image contains multiple single-color areas, the output file size will be significantly reduced. However, if you save a 32-bit photo to this format (which you must first dither to reduce to 256 colors), the input image will be unnecessarily large, and in this case it is better to use an uncompressed format.
Code: (Select All)
'-------------------------------------------------------------
' HlavnÝ program (ukßzka) Main program (example)
' NaŔte 8bitovř obrßzek volnřm _LoadImage("xxx.jpg", 256)
' a ulo×Ý jej do souboru test_RLE8.bmp s RLE8 kompresÝ.
Loads an 8-bit image using _LoadImage("xxx.jpg", 256)
' and saves it to file test_RLE8.bmp with RLE8 compression.
'-------------------------------------------------------------
Dim srcImg As Long
srcImg = _LoadImage("panda.png", 256) ' <--- musÝ břt 8bitovř obrßzek <--- must be an 8-bit image here!
If srcImg = -1 Then
Print "Error opening source image." ' Chyba p°i otevÝrßnÝ zdrojovÚho obrßzku Error opening source image.
End
End If
Print "Saving source image to file test_RLE8.bmp" ' Uklßdßme zdrojovř obrßzek do test_RLE8.bmp Saving the source image to file test_RLE8.bmp
SaveAs8BitRLEBMP srcImg, "test_RLE8.bmp"
_FreeImage srcImg
Print "File test_RLE8.bmp created. Trying open it with _LoadImage..."
' Soubor test_RLE8.bmp vytvo°en. ZkouÜÝme jej otev°Ýt pomocÝ _LoadImage... File test_RLE8.bmp created. Trying to open it with _LoadImage...
image = _LoadImage("test_rle8.bmp"): Print image
Print "Opening test_RLE8.bmp with Load8bitRLEBMP function..."
' OtevÝrßme test_RLE8.bmp pomocÝ funkce Load8bitRLEBMP Opening test_RLE8.bmp with the Load8bitRLEBMP function...
Sleep 2
image = Load8BitRLEBMP("test_rle8.bmp")
Screen image
End
'----------------------------------------------------------------------------------------------------------------------
' ULOÄ═ 8bitovř obrßzek s RLE8 kompresÝ do BMP souboru. Saves an 8-bit image with RLE8 compression into a BMP file.
' P°edpoklßdß, ×e zdrojovř obrßzek je opravdu 8bit We assume that source image is really 8bit (1byte to pixel)
' - Data se naŔtou do °etýzce (top-down po°adÝ) - Data are loaded into a string (top-down order)
' - V cyklu (y=0..H-1 = bottom-up) zpracujeme °ßdky "odspodu nahoru"
' a ka×dř °ßdek zakˇdujeme pomocÝ RLE8EncodeLine$, and each line is encoded using RLE8EncodeLine$
' - Nakonec se zapÝÜe BMP hlaviŔka, paleta a RLE8 data. Finally, the BMP header, palette, and RLE8 data are written.
'----------------------------------------------------------------------------------------------------------------------
Sub SaveAs8BitRLEBMP (sourceImg&, outputFile$)
' Rozmýry obrßzku Determine image dimensions
Dim W As Long, H As Long
W = _Width(sourceImg&)
H = _Height(sourceImg&)
Dim totalPixels As Long
totalPixels = W * H
' NaŔteme vÜechna 8bitovß data do °etýzce (top-down po°adÝ) Load all 8-bit data into a string (top-down order)
Dim raw As String
raw$ = Space$(totalPixels)
Dim m As _MEM
m = _MemImage(sourceImg&)
_MemGet m, m.OFFSET, raw$
_MemFree m
' P°ipravÝme vřslednř RLE8 °etýzec Prepare the resulting RLE8 string
Dim rleData As String
rleData = ""
' Pro ka×dř °ßdek v po°adÝ bottom-up:
' ěßdek y v BMP => reßlnř °ßdek = (H-1) - y v raw$
Dim y As Long
For y = 0 To H - 1
Dim realRow As Long
realRow = (H - 1) - y
Dim offset As Long
offset = realRow * W
Dim lineData As String
lineData$ = Mid$(raw$, offset + 1, W)
' Zakˇdujeme jeden °ßdek pomocÝ RLE8EncodeLine$ Encode one line using RLE8EncodeLine$
rleData = rleData + RLE8EncodeLine$(lineData$)
' Na konec °ßdku p°idßme "0,0" (End Of Line) Append "0,0" (End Of Line) at the end of the line
rleData = rleData + Chr$(0) + Chr$(0)
Next y
' Po poslednÝm °ßdku je jeÜtý "0,1" (End Of Bitmap) After the last line, add "0,1" (End Of Bitmap)
rleData = rleData + Chr$(0) + Chr$(1)
' -------------------------------------------------------
' Vytvo°Ýme BMP hlaviŔku (FileHeader + InfoHeader). Create the BMP header (FileHeader + InfoHeader).
Type BMP8BitHeader
signature As String * 2 ' "BM"
fileSize As Long
reserved1 As Integer
reserved2 As Integer
dataOffset As Long
infoHeaderSize As Long
width As Long
height As Long
planes As Integer
bitsPerPixel As Integer
compression As Long ' BI_RLE8 = 1
imageSize As Long
xPelsPerMeter As Long
yPelsPerMeter As Long
colorsUsed As Long
importantColors As Long
End Type
Dim bmp As BMP8BitHeader
bmp.signature = "BM"
bmp.reserved1 = 0
bmp.reserved2 = 0
bmp.infoHeaderSize = 40
bmp.width = W
bmp.height = H
bmp.planes = 1
bmp.bitsPerPixel = 8
bmp.compression = 1 ' BI_RLE8 BI_RLE8
bmp.imageSize = Len(rleData)
bmp.xPelsPerMeter = 0
bmp.yPelsPerMeter = 0
bmp.colorsUsed = 256
bmp.importantColors = 256
Dim headerSize As Long
headerSize = 14 + 40 + (256 * 4) ' FileHeader + InfoHeader + palette
bmp.dataOffset = headerSize
bmp.fileSize = headerSize + bmp.imageSize
' Paleta: 256 polo×ek Palette: 256 entries
Dim ColorTable(0 To 255) As _Unsigned Long
Dim iColor As Long
For iColor = 0 To 255
ColorTable(iColor) = _PaletteColor(iColor, sourceImg&)
Next iColor
' Zßpis vřslednÚho souboru Write the output file
If _FileExists(outputFile$) Then Kill outputFile$
Open outputFile$ For Binary As #1
' FileHeader (14 bajt¨) FileHeader (14 bytes)
Put #1, , bmp.signature
Put #1, , bmp.fileSize
Put #1, , bmp.reserved1
Put #1, , bmp.reserved2
Put #1, , bmp.dataOffset
' InfoHeader (40 bajt¨) InfoHeader (40 bytes)
Put #1, , bmp.infoHeaderSize
Put #1, , bmp.width
Put #1, , bmp.height
Put #1, , bmp.planes
Put #1, , bmp.bitsPerPixel
Put #1, , bmp.compression
Put #1, , bmp.imageSize
Put #1, , bmp.xPelsPerMeter
Put #1, , bmp.yPelsPerMeter
Put #1, , bmp.colorsUsed
Put #1, , bmp.importantColors
' Paleta (256 * 4 bajt¨) Palette (256 * 4 bytes)
For iColor = 0 To 255
Put #1, , ColorTable(iColor)
Next iColor
' Zßpis RLE8 dat Write RLE8 data
Put #1, , rleData
Close #1
End Sub
'-------------------------------------------------------------
' RLE8EncodeLine$ (zakˇduje jeden °ßdek do RLE8) Encodes one line using RLE8
'
' Jednoduchř, klasickř postup:
' - ZkusÝme spoŔÝtat run (>=2?), pokud ano => [count][value]. Try to count a run (>=2?), if so => [count][value].
' - Jinak vytvo°Ýme "absolutnÝ" blok, do nýj sbÝrßme pixely,
' dokud nenarazÝme na run >=2 nebo 255 Ŕi konec °ßdku. Otherwise, form an "absolute" block, gathering pixels until encountering a run >=2, 255, or end of line.
' - AbsolutnÝ blok => 0, [count], data, + pad byte (pokud count je lichř). Absolute block => 0, [count], data, plus a pad byte (if count is odd).
'----------------------------------------------------------------------------- because absolute blocks working bad, all blocks in program are cset as RLE (condition is not If RLE >=2 but
Function RLE8EncodeLine$ (lineData$) ' but If RLE > = 1
Dim result As String
result = ""
Dim length As Long
length = Len(lineData$)
Dim i As Long
i = 1
j = 1
Do While i <= length
' ZjistÝme run Determine the run
Dim c As _Unsigned _Byte
c = Asc(Mid$(lineData$, i, 1))
Dim runCount As Long
runCount = 1
' Kolik se opakuje? How many times does it repeat?
While (i + runCount <= length) And (runCount < 255)
If Asc(Mid$(lineData$, i + runCount, 1)) = c Then
runCount = runCount + 1
Else
Exit While
End If
Wend
If runCount >= 1 Then ' tu mß břt 2, ale s1 to funguje should be 2, but works with 1 - specification is 2. Then if RunLenght is 1, program create absolut block. BUT this
' Bý×ový zakˇdovanř Encoded as a run cause bug in image (i do not know why) - image from this point is black (if 2 is used). Something in ELSE condition is wrong, but i
result = result + Chr$(runCount) + Chr$(c) ' don't know what...
i = i + runCount
Else
' AbsolutnÝ re×im Absolute mode - in this ELSE condition is somewhere bug... see, in this version program never come here (because this part
Dim absBlock As String ' is wrong. Rwrite IF runCount => 2 above and then run it and see. Test output images also in photo viewer, so you can see, that
absBlock = "" ' this bug is here, not in Load8BitRLEBMP& function...
Dim absCount As Long
absCount = 0
j = 1
Do While (i <= length) And (absCount < 255)
' P°idßme 1 pixel Add one pixel
i = i + 1
absBlock = absBlock + Mid$(lineData$, i, 1)
absCount = absCount + 1
' Dßle zkontrolujeme, jestli za i nenÝ run >=2 Then check if a run >=2 starts at i
If i <= length Then
Dim c2 As _Unsigned _Byte
c2 = Asc(Mid$(lineData$, i, 1))
Dim r2 As Long
r2 = 1
While (i + r2 <= length) And (r2 < 255)
If Asc(Mid$(lineData$, i + r2, 1)) = c2 Then
r2 = r2 + 1
absBlock = absBlock + Chr$(c2)
Else
Exit While
End If
Wend
If r2 >= 2 Then
Exit Do ' naÜli jsme run, ukonŔÝme absolutnÝ blok Found a run, exit absolute block (if we found two or more then same pixels (colors) return back to RLE)
End If
End If
j = j + 1
Loop
' Ulo×Ýme ABS blok => 0, [absCount], data Store the absolute block => 0, [absCount], data 0 is signal for encoder, that here start absolute block, then is count (how much pixels, max is 255), then bytes with colors.
result = result + Chr$(0) + Chr$(absCount) + absBlock
' ZarovnßnÝ na sudř poŔet bajt¨ Pad to even number of bytes
If (absCount Mod 2) <> 0 Then
result = result + Chr$(0)
End If
End If
Loop
RLE8EncodeLine$ = result
End Function
Function Load8BitRLEBMP& (fileName$)
' Otev°e BMP soubor, naŔte hlaviŔku, paletu a RLE8 data
' a dekˇduje je do novÚho 8bitovÚho obrßzku v QB64PE. Opens a BMP file, loads the header, palette, and RLE8 data,
' Returns handle novÚho obrßzku, nebo 0 p°i chybý. and decodes them into a new 8-bit image in QB64PE.
Dim fileNum As Integer
fileNum = FreeFile
Open fileName$ For Binary As #fileNum
If LOF(fileNum) < 54 Then
Print "Soubor je p°ÝliÜ malř, aby to byl platnř BMP." ' Soubor je p°ÝliÜ malř pro platnř BMP File is too small to be a valid BMP.
Close #fileNum
Load8BitRLEBMP& = 0
Exit Function
End If
' [1] NaŔtenÝ 14bytovÚ BMP hlaviŔky Load the 14-byte BMP header
Dim signature As String * 2
Dim fileSize As Long, reserved1 As Integer, reserved2 As Integer, dataOffset As Long
Get #fileNum, , signature
If signature <> "BM" Then
Print "Nejednß se o platnř BMP soubor (chybÝ podpis 'BM')!" ' NenÝ platnř BMP soubor (chybÝ 'BM') Not a valid BMP file (missing 'BM' signature)!
Close #fileNum
Load8BitRLEBMP& = 0
Exit Function
End If
Get #fileNum, , fileSize
Get #fileNum, , reserved1
Get #fileNum, , reserved2
Get #fileNum, , dataOffset
' [2] NaŔtenÝ BITMAPINFOHEADER (40 bajt¨) Load the BITMAPINFOHEADER (40 bytes)
Dim infoHeaderSize As Long, width As Long, height As Long
Dim planes As Integer, bitsPerPixel As Integer, compression As Long
Dim imageSize As Long, xPelsPerMeter As Long, yPelsPerMeter As Long
Dim colorsUsed As Long, importantColors As Long
Get #fileNum, , infoHeaderSize
Get #fileNum, , width
Get #fileNum, , height
Get #fileNum, , planes
Get #fileNum, , bitsPerPixel
Get #fileNum, , compression
Get #fileNum, , imageSize
Get #fileNum, , xPelsPerMeter
Get #fileNum, , yPelsPerMeter
Get #fileNum, , colorsUsed
Get #fileNum, , importantColors
If bitsPerPixel <> 8 Then
Print "Nejednß se o 8bit BMP!" ' Obrßzek nenÝ 8bitovř Image is not an 8-bit BMP!
Close #fileNum
Load8BitRLEBMP& = 0
Exit Function
End If
If compression <> 1 Then
Print "BMP nenÝ komprimovßn metodou RLE8 (BI_RLE8)!" ' BMP nenÝ komprimovßn RLE8 BMP is not compressed with RLE8 (BI_RLE8)!
Close #fileNum
Load8BitRLEBMP& = 0
Exit Function
End If
' Pokud v hlaviŔce nenÝ uvedeno colorsUsed, nastavÝme 256 If colorsUsed is not specified in the header, set to 256
If colorsUsed = 0 Or colorsUsed > 256 Then
colorsUsed = 256
End If
' [3] NaŔtenÝ palety (a× 256 zßznam¨) Load the palette (up to 256 entries)
Dim pal(0 To 255) As _Unsigned Long
Dim i As Long
For i = 0 To colorsUsed - 1
Dim blue As _Unsigned _Byte, green As _Unsigned _Byte, red As _Unsigned _Byte, reservedPal As _Unsigned _Byte
Get #fileNum, , blue
Get #fileNum, , green
Get #fileNum, , red
Get #fileNum, , reservedPal
' SestavÝme do &H00RRGGBB Assemble into &H00RRGGBB format
pal(i) = _RGBA32(red, green, blue, reservedPal)
Next i
' ZbylÚ barvy, pokud colorsUsed < 256, lze doplnit Ŕernou Remaining colors, if colorsUsed < 256, can be filled with black
For i = colorsUsed To 255
' pal(i) = &H0
Next i
' [4] NastavenÝ ukazatele na data Seek to the data offset
Seek #fileNum, dataOffset + 1
If imageSize = 0 Then
' Pokud je imageSize=0, pou×ijeme zbytek souboru If imageSize=0, use the rest of the file
imageSize = fileSize - dataOffset
End If
' [5] NaŔtenÝ RLE8 dat Load the RLE8 data
If imageSize < 2 Then
Print "BMP: imageSize je p°ÝliÜ malř, neplatnß data." ' imageSize je p°ÝliÜ malř imageSize is too small, invalid data.
Close #fileNum
Load8BitRLEBMP& = 0
Exit Function
End If
Dim rleData As String
rleData = Space$(imageSize)
Get #fileNum, , rleData
Close #fileNum
' [6] Vytvo°enÝ novÚho 8bitovÚho obrßzku v QB64PE Create a new 8-bit image in QB64PE
Dim img As Long
img = _NewImage(width, height, 256)
' NastavenÝ palety Set the palette
For i = 0 To 255
_PaletteColor i, pal(i), img
Next i
' ZÝskßnÝ pamýŁovÚho bloku obrßzku Obtain the memory block of the image
Dim memImg As _MEM
memImg = _MemImage(img)
' SpoŔÝtßme rowPitch = celkovß velikost / poŔet °ßdk¨
' (V QB64PE 8bit je ulo×en lineßrný bez mezer) Calculate rowPitch = total size / number of rows
Dim rowPitch As Long
rowPitch = memImg.SIZE \ height ' Pro 8bit by to mýlo staŔit For 8-bit, this should suffice
' [7] DekˇdovßnÝ RLE8 dat Decode the RLE8 data
Dim dataLen As Long
dataLen = Len(rleData)
Dim curRow As Long
curRow = 0
Dim curCol As Long
curCol = 0
Dim posByte As Long
posByte = 1
Do While posByte <= dataLen
' Pokud jsme na konci, ukonŔÝme If at end, exit loop
If posByte > dataLen Then Exit Do
Dim countByte As _Unsigned _Byte
countByte = Asc(Mid$(rleData, posByte, 1))
posByte = posByte + 1
' Pokud jsme na konci, ukonŔÝme Check end again
If posByte > dataLen Then Exit Do
Dim dataByte As _Unsigned _Byte
dataByte = Asc(Mid$(rleData, posByte, 1))
posByte = posByte + 1
If countByte = 0 Then
' --- SpecißlnÝ p°Ýkazy --- --- Special commands ---
Select Case dataByte
Case 0
' Konec °ßdku End of line
curRow = curRow + 1
curCol = 0
Case 1
' Konec bitmapy End of bitmap
Exit Do
Case 2
' Delta posun Delta move
If posByte + 1 <= dataLen Then
Dim dx As _Unsigned _Byte, dy As _Unsigned _Byte
dx = Asc(Mid$(rleData, posByte, 1))
dy = Asc(Mid$(rleData, posByte + 1, 1))
posByte = posByte + 2
curCol = curCol + dx
curRow = curRow + dy
Else
Exit Do
End If
Case Else
' AbsolutnÝ blok o dÚlce dataByte Absolute block with length dataByte
Dim absCount As Long
absCount = dataByte
If absCount = 0 Then Exit Do
If posByte + absCount - 1 > dataLen Then Exit Do
Dim absData As String
absData = Mid$(rleData, posByte, absCount)
posByte = posByte + absCount
' ZkopÝrujeme do obrßzku Copy into the image
Dim k As Long
For k = 1 To absCount
Dim pixIndex As _Unsigned _Byte
pixIndex = Asc(Mid$(absData, k, 1))
' Bottom-up => fyzickř °ßdek = (height - 1 - curRow) Bottom-up: physical row = (height - 1 - curRow)
If curRow < height Then
If curCol < width Then
Dim memOffset As Long
memOffset = (height - 1 - curRow) * rowPitch + curCol
' Zßpis pixelu Write pixel
_MemPut memImg, memImg.OFFSET + memOffset, pixIndex As _UNSIGNED _BYTE
End If
End If
curCol = curCol + 1
If curCol >= width Then Exit For
Next k
' ZarovnßnÝ: pokud je absCount lichÚ, p°eskoŔÝme jeden bajt Pad: if absCount is odd, skip one pad byte
If (absCount Mod 2) <> 0 Then
If posByte <= dataLen Then
posByte = posByte + 1 ' pad byte
End If
End If
End Select
Else
' --- Kˇdovanř (run) re×im --- --- Encoded (run) mode ---
Dim runCount As Long
runCount = countByte
Dim c As _Unsigned _Byte
c = dataByte
' Opakujeme runCount krßt Repeat runCount times
Dim j As Long
For j = 1 To runCount
If curRow < height Then
If curCol < width Then
memOffset = (height - 1 - curRow) * rowPitch + curCol
_MemPut memImg, memImg.OFFSET + memOffset, c As _UNSIGNED _BYTE
End If
End If
curCol = curCol + 1
If curCol >= width Then Exit For
Next j
End If
If curRow >= height Then Exit Do
Loop
Load8BitRLEBMP& = img
End Function
The previous program has the same problem as RLE4 with absolute blocks, but it is modified to work.
The following is the 16-bit BMP format. This is an uncompressed format (RLE compression is used for files with a palette, so this is no longer in this case). Three colors use _Unsigned Integer to store one pixel, so 2 bytes and a maximum value of 65535. In this version, 5 bits are used for each color (R,G,B) and one bit is not used. In this version, I discovered a bug in _LoadImage during testing, which supports this format, loads it - but then displays some colors incorrectly. I verified that there is no bug in the program using the Windows photo viewer and another browser, both output files displayed exactly as nicely as the function in the Load16BitBMP555 program. This format is essentially the so-called HiColor mode, which was used in older Windows. The advantage is a better color range than in 8 bits and a third smaller size than in the 24 bit format.
Code: (Select All)
'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------
' HlavnÝ program: Main program:
' NaŔtýte zdrojovř obrßzek (nap°. "panda.png") v 32bit re×imu a ulo×te jej jako Load the source image (e.g. "panda.png") in 32-bit mode and save it as
' 16bit BMP ve formßtu 5-5-5 (BI_BITFIELDS) do souboru "output_16bit_555.bmp". 16-bit BMP in 5-5-5 format (BI_BITFIELDS) into the file "output_16bit_555.bmp".
'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------
Dim srcImg As Long
srcImg = _LoadImage("panda.png", 32) '<------------------ musÝ břt 32bitovř obrßzek must be a 32-bit image
If srcImg = -1 Then
Print "Error loading source image."
End
End If
Print "Saving your source image to file output_16bit_555.bmp" 'proŔ 555? 5 bit¨ Ŕervenß, 5 bit¨ zelenß, 5 bit¨ modrß na jeden pixel why 555? 5 bits red, 5 bits green, 5 bits blue per pixel!
Save16BitBMP555 srcImg, "output_16bit_555.bmp"
_FreeImage srcImg
Print "File output_16bit_555.bmp saved as 16bit BMP (5-5-5)."
i = _LoadImage("output_16bit_555.bmp", 256)
Print "Trying open this format with Loadimage. LoadImage return: "; i 'P°i testu zjkiÜtýna chyba kdy se nýkterÚ foto obarvilo Üpatný. LoadImage has a bug, as some images are not colored correctly!
Sleep 5
Screen i
_FullScreen
Print "This is compatible format! - But _LoadImage colorize some images not correctly."
Sleep 5
j = Load16BitBMP555("output_16bit_555.bmp") ' obrßzky jsou v×dy sprßvný vykresleny images are always rendered correctly.
Screen j
_FullScreen
Print "And this is image loaded with function Load16bitBMP555. Press any key for end."
Sleep
'-----------------------------------------------------------------------------------------------------------------------------------------------------------------
' Save16BitBMP555: Save16BitBMP555:
' Ulo×te zdrojovř obrßzek (p°edpoklßdßme 32bit) do 16bit BMP ve formßtu 5-5-5. Save the source image (assumed to be 32-bit) as a 16-bit BMP in 5-5-5 format.
'
' Pou×Ývß BI_BITFIELDS (compression = 3) a zapisuje jeÜtý 4-bajtovÚ masky: Uses BI_BITFIELDS (compression = 3) and writes three 4-byte masks:
' ╚ervenß maska: &H7C00 (5 bit¨) Red mask: &H7C00 (5 bits)
' Zelenß maska: &H03E0 (5 bit¨) Green mask: &H03E0 (5 bits)
' Modrß maska: &H001F (5 bit¨) Blue mask: &H001F (5 bits)
'
' Pixelovß data jsou p°evedena z 32bit na 16bit (5-5-5). Pixel data are converted from 32-bit to 16-bit (5-5-5).
' ěßdky jsou zapisovßny bottom-up a zarovnßny na 4 bajty. Rows are written bottom-up and aligned to 4 bytes.
'-----------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub Save16BitBMP555 (imgHandle As Long, fileName As String)
' Zjistýte rozmýry zdrojovÚho obrßzku. Determine the dimensions of the source image.
Dim W As Long, H As Long
W = _Width(imgHandle)
H = _Height(imgHandle)
' Pro 16bit BMP: ka×dř pixel = 2 bajty. For 16-bit BMP: each pixel = 2 bytes.
' ěßdek se musÝ zarovnat na 4 bajty: Row must be aligned to 4 bytes:
Dim rowBytes As Long
rowBytes = (((W * 2) + 3) \ 4) * 4
Dim imageSize As Long
imageSize = rowBytes * H
' HlaviŔky: Headers:
' FileHeader: 14 bajt¨ FileHeader: 14 bytes
' InfoHeader: 40 bajt¨ InfoHeader: 40 bytes
' Bitfield masky: 3 * 4 = 12 bajt¨ Bitfield masks: 3 * 4 = 12 bytes
Dim headerSize As Long
headerSize = 14 + 40 + 12
Dim fileSize As Long
fileSize = headerSize + imageSize
' --- BMP FileHeader (14 bajt¨) --- --- BMP FileHeader (14 bytes) ---
Type BMPFileHeader
bfType As String * 2 ' "BM"
bfSize As Long
bfRes1 As Integer
bfRes2 As Integer
bfOffBits As Long
End Type
Dim fh As BMPFileHeader
fh.bfType = "BM"
fh.bfSize = fileSize
fh.bfRes1 = 0
fh.bfRes2 = 0
fh.bfOffBits = headerSize
' --- Zßpis FileHeader --- --- Write FileHeader ---
Open fileName For Binary As #1
Put #1, , fh.bfType
Put #1, , fh.bfSize
Put #1, , fh.bfRes1
Put #1, , fh.bfRes2
Put #1, , fh.bfOffBits
' --- BMP InfoHeader (40 bajt¨) --- --- BMP InfoHeader (40 bytes) ---
Type BMPInfoHeader
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long ' BI_BITFIELDS = 3
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Dim ih As BMPInfoHeader
ih.biSize = 40
ih.biWidth = W
ih.biHeight = H
ih.biPlanes = 1
ih.biBitCount = 16
ih.biCompression = 3 ' BI_BITFIELDS
ih.biSizeImage = imageSize
ih.biXPelsPerMeter = 0
ih.biYPelsPerMeter = 0
ih.biClrUsed = 0 ' V 16bit s maskami se paleta zpravidla nepou×Ývß In 16-bit with masks, the palette is usually not used
ih.biClrImportant = 0
' --- Zßpis InfoHeader --- --- Write InfoHeader ---
Put #1, , ih.biSize
Put #1, , ih.biWidth
Put #1, , ih.biHeight
Put #1, , ih.biPlanes
Put #1, , ih.biBitCount
Put #1, , ih.biCompression
Put #1, , ih.biSizeImage
Put #1, , ih.biXPelsPerMeter
Put #1, , ih.biYPelsPerMeter
Put #1, , ih.biClrUsed
Put #1, , ih.biClrImportant
' --- Zßpis bitfield masek (12 bajt¨: 3x4) --- --- Write bitfield masks (12 bytes: 3x4) ---
Dim redMask As Long, greenMask As Long, blueMask As Long
redMask = &H7C00 ' 0x7C00: 5 bit¨ pro Ŕervenou (bits 10-14) 0x7C00: 5 bits for red (bits 10-14)
greenMask = &H03E0 ' 0x03E0: 5 bit¨ pro zelenou (bits 5-9) 0x03E0: 5 bits for green (bits 5-9)
blueMask = &H001F ' 0x001F: 5 bit¨ pro modrou (bits 0-4) 0x001F: 5 bits for blue (bits 0-4)
Put #1, , redMask
Put #1, , greenMask
Put #1, , blueMask
' --- P°evod a zßpis pixelovřch dat --- --- Conversion and writing of pixel data ---
' P°edpoklßdßme, ×e vstupnÝ obrßzek je 32bitovř (top-down). Assume the input image is 32-bit (top-down).
' BMP vy×aduje bottom-up, proto pro ka×dř °ßdek y (0 a× H-1) BMP requires bottom-up, so for each row y (0 to H-1)
' pou×ijeme °ßdek (H-1-y) ze zdroje. we use row (H-1-y) from the source.
Dim memImg As _MEM
memImg = _MemImage(imgHandle)
' NaŔteme celou obrazovou oblast do dvourozmýrnÚho pole RawLine() Load the entire image area into a 2D array RawLine()
Dim RawLine(0 To W - 1, 0 To H - 1) As _Unsigned Long
_MemGet memImg, memImg.OFFSET, RawLine()
Dim rowData As String
rowData = ""
Dim pixel16 As _Unsigned Integer
Dim r As _Unsigned _Byte, g As _Unsigned _Byte, b As _Unsigned _Byte
Dim x As Long, y As Long
For y = 0 To H - 1
Dim realRow As Long
realRow = (H - 1) - y ' BMP °ßdky jsou bottom-up BMP rows are bottom-up
Dim lineData As String
lineData = ""
For x = 0 To W - 1
Dim pixel As _Unsigned Long
pixel = RawLine(x, realRow)
' Extrahujeme 8bitovÚ slo×ky z 32bitovÚho pixelu. Extract 8-bit components from the 32-bit pixel.
r = _Red32(pixel)
g = _Green32(pixel)
b = _Blue32(pixel)
' P°evod do 16bit 5-5-5: Convert to 16-bit 5-5-5:
' Ka×dß slo×ka se p°evede na 5 bit¨ (posun o 3 bity). Each component is converted to 5 bits (shift by 3 bits).
' Sestavenř pixel: Ŕervenß << 10, zelenß << 5, modrß Composed pixel: red << 10, green << 5, blue
pixel16 = _ShL((r \ 8), 10) Or _ShL((g \ 8), 5) Or (b \ 8)
lineData = lineData + Chr$(pixel16 And &HFF) + Chr$((pixel16 \ &H100) And &HFF)
Next x
' Zarovnanř °ßdek na 4 bajty. Row aligned to 4 bytes.
Dim padCount As Long
padCount = rowBytes - (W * 2)
If padCount > 0 Then
lineData = lineData + String$(padCount, Chr$(0))
End If
rowData = rowData + lineData
Next y
Erase RawLine
' Zßpis pixelovřch dat do souboru. Write pixel data to the file.
Put #1, , rowData
Close #1
End Sub
Function Load16BitBMP555& (fileName$)
' Otev°e 16bit BMP (5-5-5) se BITFIELDS a dekˇduje jej do 32bitovÚho obrßzku. Opens a 16-bit BMP (5-5-5) with BITFIELDS and decodes it to a 32-bit image.
Dim fileNum As Integer
fileNum = FreeFile
Open fileName$ For Binary As #fileNum
' --- [1] NaŔtenř BMP FileHeader (14 bajt¨) --- --- [1] Read BMP FileHeader (14 bytes) ---
Dim signature As String * 2
Dim bfSize As Long, bfRes1 As Integer, bfRes2 As Integer, bfOffBits As Long
Get #fileNum, , signature
If signature <> "BM" Then
Print "Neplatnř BMP soubor (chybnř podpis)."
Close #fileNum
Load16BitBMP555& = 0
Exit Function
End If
Get #fileNum, , bfSize
Get #fileNum, , bfRes1
Get #fileNum, , bfRes2
Get #fileNum, , bfOffBits
' --- [2] NaŔtenř BMP InfoHeader (40 bajt¨) --- --- [2] Read BMP InfoHeader (40 bytes) ---
Dim biSize As Long, biWidth As Long, biHeight As Long
Dim biPlanes As Integer, biBitCount As Integer, biCompression As Long
Dim biSizeImage As Long, biXPelsPerMeter As Long, biYPelsPerMeter As Long
Dim biClrUsed As Long, biClrImportant As Long
Get #fileNum, , biSize
Get #fileNum, , biWidth
Get #fileNum, , biHeight
Get #fileNum, , biPlanes
Get #fileNum, , biBitCount
Get #fileNum, , biCompression
Get #fileNum, , biSizeImage
Get #fileNum, , biXPelsPerMeter
Get #fileNum, , biYPelsPerMeter
Get #fileNum, , biClrUsed
Get #fileNum, , biClrImportant
If biBitCount <> 16 Then
Print "BMP nenÝ 16bit."
Close #fileNum
Load16BitBMP555& = 0
Exit Function
End If
If biCompression <> 3 Then
Print "BMP nenÝ komprimovßn BITFIELDS metodou (compression=3)."
Close #fileNum
Load16BitBMP555& = 0
Exit Function
End If
' --- [3] NaŔtenÚ bitfield masek (12 bajt¨) --- --- [3] Read bitfield masks (12 bytes) ---
Dim redMask As _Unsigned Long, greenMask As _Unsigned Long, blueMask As _Unsigned Long
Get #fileNum, , redMask
Get #fileNum, , greenMask
Get #fileNum, , blueMask
' Ový°Ýme pro 5-5-5: redMask = &H7C00, greenMask = &H03E0, blueMask = &H001F
' --- [4] NaŔtenÝ pixelovřch dat --- --- [4] Read pixel data ---
Seek #fileNum, bfOffBits + 1
If biSizeImage = 0 Then biSizeImage = bfSize - bfOffBits
Dim rawData As String
rawData = Space$(biSizeImage)
Get #fileNum, , rawData
Close #fileNum
' --- [5] Vytvo°enř novř 32bitovř obrßzek --- --- [5] Create new 32-bit image ---
Dim newImg As Long
newImg = _NewImage(biWidth, biHeight, 32)
Dim newMem As _MEM
newMem = _MemImage(newImg)
' P°edpoklßdßme, ×e 32bitovř obrßzek mß °ßdkovou dÚlku = biWidth * 4 bajt¨. Assume the 32-bit image has a row length = biWidth * 4 bytes.
Dim newRowStep As Long
newRowStep = biWidth * 4
' --- [6] DekˇdovßnÝ pixelovřch dat --- --- [6] Decode pixel data ---
' BMP °ßdky jsou zarovnßny na 4 bajty: BMP rows are aligned to 4 bytes:
Dim rowBytes As Long
rowBytes = (((biWidth * 2) + 3) \ 4) * 4
Dim x As Long, y As Long
Dim poss As Long
poss = 1
Dim fileRowData As String
' Pro ka×dř °ßdek (BMP uklßdß bottom-up) For each row (BMP stores bottom-up)
For y = 0 To biHeight - 1
fileRowData = Mid$(rawData, poss, rowBytes)
poss = poss + rowBytes
' CÝlovř °ßdek v novÚm obrßzku: BMP °ßdek y odpovÝdß °ßdku (biHeight - 1 - y) Target row in new image: BMP row y corresponds to row (biHeight - 1 - y)
Dim targetRow As Long
targetRow = biHeight - 1 - y
For x = 0 To biWidth - 1
Dim byte1 As _Unsigned _Byte, byte2 As _Unsigned _Byte, pixel16 As _Unsigned Integer
byte1 = Asc(Mid$(fileRowData, (x * 2) + 1, 1))
byte2 = Asc(Mid$(fileRowData, (x * 2) + 2, 1))
pixel16 = byte1 Or (byte2 * 256)
' V 5-5-5 formßtu jsou vÜechny kanßly 5bitovÚ: In 5-5-5 format, all channels are 5-bit:
Dim red5 As Long, green5 As Long, blue5 As Long
red5 = _ShR((pixel16 And redMask), 10) ' redMask = &H7C00: bit 10-14
green5 = _ShR((pixel16 And greenMask), 5) ' greenMask = &H03E0: bit 5-9
blue5 = pixel16 And blueMask ' blueMask = &H001F: bit 0-4
' P°evedeme 5bitovÚ hodnoty na 8bit (˙mýrný) Convert 5-bit values to 8-bit (proportionally)
Dim r8 As _Unsigned _Byte, g8 As _Unsigned _Byte, b8 As _Unsigned _Byte
r8 = (red5 * 255) \ 31
g8 = (green5 * 255) \ 31
b8 = (blue5 * 255) \ 31
Dim pixel32 As _Unsigned Long
pixel32 = _RGB32(r8, g8, b8)
Dim offsetTarget As Long
offsetTarget = newMem.OFFSET + (targetRow * newRowStep) + (x * 4)
_MemPut newMem, offsetTarget, pixel32 As _UNSIGNED LONG
Next x
Next y
Load16BitBMP555& = newImg
End Function
And finally, I have the 16-bit BMP 565 format. This is basically the same as the previous case, only 6bit is used for green, unlike BMP555. This format is not supported by _LoadImage (that wouldn't make sense), the output file size is the same as in the previous case, it's just for fun. Because of the color shift, there's also a loader written here that will display the image correctly, but in this case there's a compatibility problem with other photo viewers, so they'll display the image with distorted colors. As I said, this last program is just for fun.
Code: (Select All)
'------------------------------------------------------------- -------------------------------------------------------------
' HlavnÝ program: Main program:
' NaŔtýte zdrojovř obrßzek (nap°. "panda.png") a ulo×te jej jako Load the source image (e.g. "panda.png") and save it as
' 16bit BMP (BI_BITFIELDS, 5-6-5) do souboru "output_16bit.bmp". 16-bit BMP (BI_BITFIELDS, 5-6-5) into the file "output_16bit.bmp".
'------------------------------------------------------------- -------------------------------------------------------------
Dim srcImg As Long
srcImg = _LoadImage("panda.png", 32) '<-------- insert 32 bit image here
If srcImg = -1 Then
Print "Error opening source file." ' Failed to load panda.png!
End
End If
Print "Saving your image to file output_16bit.bmp..."
Save16BitBMP srcImg, "output_16bit.bmp"
_FreeImage srcImg
Print "File output_16bit.bmp saved as 16bit BMP. Press any key."
Sleep
i = _LoadImage("output_16bit.bmp", 32)
Print "Trying load old 16bit BMP format with _LoadImage: "; i
Sleep 2
i& = Load16BitBMP("output_16bit.bmp")
Screen i&
Print "File is loaded with function Load16bitBMP"
'------------------------------------------------------------- -------------------------------------------------------------
' Save16BitBMP: Save16BitBMP:
' Ulo×te zdrojovř obrßzek (p°edpoklßdßme 32bit) do 16bit BMP. Save the source image (assumed to be 32-bit) as a 16-bit BMP.
'
' Pou×Ývß BI_BITFIELDS (compression=3) a zapisuje tÚ× 4-bajtovÚ Uses BI_BITFIELDS (compression=3) and also writes 4-byte
' masky pro 5-6-5 formßt: masks for 5-6-5 format:
' Red mask: &HF800 Red mask: &HF800
' Green mask: &H07E0 Green mask: &H07E0
' Blue mask: &H001F Blue mask: &H001F
'
' BMP se ulo×Ý jako nekomprimovanř (kromý týchto mask) soubor, BMP is saved as an uncompressed file (apart from these masks),
' p°iŔem× pixelovß data jsou p°evedena do 16bit formßtu. while pixel data are converted to 16-bit format.
'------------------------------------------------------------- -------------------------------------------------------------
Sub Save16BitBMP (imgHandle As Long, fileName As String)
' Zjistýte rozmýry zdrojovÚho obrßzku. Determine the dimensions of the source image.
Dim W As Long, H As Long
W = _Width(imgHandle)
H = _Height(imgHandle)
' Pro 16bit BMP: ka×dř pixel = 2 bajty. For 16-bit BMP: each pixel = 2 bytes.
' ěßdek se musÝ zarovnat na 4 bajty, tedy: Row must be aligned to 4 bytes, so:
Dim rowBytes As Long
rowBytes = (((W * 2) + 3) \ 4) * 4
Dim imageSize As Long
imageSize = rowBytes * H
' HlaviŔky: Headers:
' FileHeader: 14 bajt¨ FileHeader: 14 bytes
' InfoHeader: 40 bajt¨ InfoHeader: 40 bytes
' Bitfield masky: 3 * 4 = 12 bajt¨ Bitfield masks: 3 * 4 = 12 bytes
Dim headerSize As Long
headerSize = 14 + 40 + 12
Dim fileSize As Long
fileSize = headerSize + imageSize
' --- BMP FileHeader (14 bajt¨) --- --- BMP FileHeader (14 bytes) ---
Type BMPFileHeader
bfType As String * 2 ' "BM"
bfSize As Long
bfRes1 As Integer
bfRes2 As Integer
bfOffBits As Long
End Type
Dim fh As BMPFileHeader
fh.bfType = "BM"
fh.bfSize = fileSize
fh.bfRes1 = 0
fh.bfRes2 = 0
fh.bfOffBits = headerSize
' --- BMP InfoHeader (40 bajt¨) --- --- BMP InfoHeader (40 bytes) ---
Type BMPInfoHeader
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long ' BI_BITFIELDS = 3
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Dim ih As BMPInfoHeader
ih.biSize = 40
ih.biWidth = W
ih.biHeight = H
ih.biPlanes = 1
ih.biBitCount = 16
ih.biCompression = 3 ' BI_BITFIELDS
ih.biSizeImage = imageSize
ih.biXPelsPerMeter = 0
ih.biYPelsPerMeter = 0
ih.biClrUsed = 0 ' V 16bit s maskami se paleta zpravidla nepou×Ývß In 16-bit with masks, the palette is usually not used.
ih.biClrImportant = 0
' --- Definice 16bit mask --- --- Definition of 16-bit masks ---
Dim redMask As Long, greenMask As Long, blueMask As Long
redMask = &HF800 ' 0xF800: 5 bit¨ pro Ŕervenou 0xF800: 5 bits for red
greenMask = &H7E0 ' 0x07E0: 6 bit¨ pro zelenou 0x07E0: 6 bits for green
blueMask = &H1F ' 0x001F: 5 bit¨ pro modrou 0x001F: 5 bits for blue
' Otev°ete soubor pro binßrnÝ zßpis. Open file for binary writing.
If _FileExists(fileName) Then Kill fileName
Open fileName For Binary As #1
' --- Zßpis FileHeader --- --- Write FileHeader ---
Put #1, , fh.bfType
Put #1, , fh.bfSize
Put #1, , fh.bfRes1
Put #1, , fh.bfRes2
Put #1, , fh.bfOffBits
' --- Zßpis InfoHeader --- --- Write InfoHeader ---
Put #1, , ih.biSize
Put #1, , ih.biWidth
Put #1, , ih.biHeight
Put #1, , ih.biPlanes
Put #1, , ih.biBitCount
Put #1, , ih.biCompression
Put #1, , ih.biSizeImage
Put #1, , ih.biXPelsPerMeter
Put #1, , ih.biYPelsPerMeter
Put #1, , ih.biClrUsed
Put #1, , ih.biClrImportant
' --- Zßpis bitfield masek (12 bajt¨: 3x4) --- --- Write bitfield masks (12 bytes: 3x4) ---
Put #1, , redMask
Put #1, , greenMask
Put #1, , blueMask
' --- P°evod a zßpis pixelovřch dat --- --- Conversion and writing of pixel data ---
' VstupnÝ obraz p°edpoklßdßme jako 32bit, ulo×enř top-down. Assume the input image is 32-bit, stored top-down.
' BMP vy×aduje bottom-up, proto pro ka×dř °ßdek y (0..H-1) BMP requires bottom-up, so for each row y (0..H-1) we use row (H-1-y) from the source.
' pou×ijeme °ßdek (H-1-y) ze zdroje
Dim memImg As _MEM
memImg = _MemImage(imgHandle)
Dim y As Long, x As Long
Dim rowData As String
rowData = ""
Dim pixel16 As _Unsigned Integer
Dim m As _MEM
m = _MemImage(imgHandle)
Dim RawLine(W - 1, H - 1) As _Unsigned Long
_MemGet m, m.OFFSET, RawLine()
_MemFree m
Dim pixel As _Unsigned Long
For y = 0 To H - 1
Dim realRow As Long
realRow = (H - 1) - y ' p°evrßcenř °ßdek inverted row
Dim lineData As String
lineData = ""
' P°edpoklßdßme, ×e memImg obsahuje 32bitovß data, We assume that memImg contains 32-bit data,
' kde ka×dř pixel zabÝrß 4 bajty . where each pixel occupies 4 bytes (order: blue, green, red, alpha).
'(po°adÝ: modrß, zelenß, Ŕervenß, alfa)
' ěßdek naŔteme najednou do °etýzce rawLine$, dÚlka = W*4 bajt¨. The row is read into the string rawLine$, length = W*4 bytes.
For x = 0 To W - 1
' NaŔteme bajty pro pixel x z rawLine$ Load bytes for pixel x from rawLine$
' Indexace: prvnÝ pixel = bajty 1-4, druhř = 5-8, atd. Indexing: first pixel = bytes 1-4, second = 5-8, etc.
pixel = RawLine(x, (H - 1) - y)
r = _Red32(pixel)
g = _Green32(pixel)
b = _Blue32(pixel)
' P°evod do 16bit 5-6-5: Convert to 16-bit 5-6-5:
' - Ŕervenß: (r \ 8) << 11 - red: (r \ 8) << 11
' - zelenß: (g \ 4) << 5 - green: (g \ 4) << 5
' - modrß: (b \ 8) - blue: (b \ 8)
pixel16 = _ShL((r \ 8), 11) Or _ShL((g \ 4), 5) Or (b \ 8)
lineData = lineData + Chr$(pixel16 And &HFF) + Chr$((pixel16 \ &H100) And &HFF)
Next x
' Zarovnejte °ßdek na nßsobek 4 bajt¨ Align the row to a multiple of 4 bytes.
Dim padCount As Long
padCount = rowBytes - (W * 2)
If padCount > 0 Then
lineData = lineData + String$(padCount, Chr$(0))
End If
rowData = rowData + lineData
Next y
Erase RawLine
' Zßpis pixelovřch dat do souboru. Write pixel data to the file.
Put #1, , rowData
Close #1
End Sub
Function Load16BitBMP& (fileName$)
' Otev°e 16bit BMP soubor a dekˇduje ho do 32bit obrßzku. Opens a 16-bit BMP file and decodes it into a 32-bit image.
Dim fileNum As Integer
fileNum = FreeFile
Open fileName$ For Binary As #fileNum
' --- [1] NaŔtenř BMP FileHeader (14 bajt¨) --- --- [1] Read BMP FileHeader (14 bytes) ---
Dim signature As String * 2
Dim bfSize As Long, bfRes1 As Integer, bfRes2 As Integer, bfOffBits As Long
Get #fileNum, , signature
If signature <> "BM" Then
Print "Invalid BMP file (wrong signature)." ' Invalid BMP file (wrong signature).
Close #fileNum
Load16BitBMP& = 0
Exit Function
End If
Get #fileNum, , bfSize
Get #fileNum, , bfRes1
Get #fileNum, , bfRes2
Get #fileNum, , bfOffBits
' --- [2] NaŔtenř BMP InfoHeader (40 bajt¨) --- --- [2] Read BMP InfoHeader (40 bytes) ---
Dim biSize As Long, biWidth As Long, biHeight As Long
Dim biPlanes As Integer, biBitCount As Integer, biCompression As Long
Dim biSizeImage As Long, biXPelsPerMeter As Long, biYPelsPerMeter As Long
Dim biClrUsed As Long, biClrImportant As Long
Get #fileNum, , biSize
Get #fileNum, , biWidth
Get #fileNum, , biHeight
Get #fileNum, , biPlanes
Get #fileNum, , biBitCount
Get #fileNum, , biCompression
Get #fileNum, , biSizeImage
Get #fileNum, , biXPelsPerMeter
Get #fileNum, , biYPelsPerMeter
Get #fileNum, , biClrUsed
Get #fileNum, , biClrImportant
If biBitCount <> 16 Then
Print "BMP is not 16bit." ' BMP is not 16-bit.
Close #fileNum
Load16BitBMP& = 0
Exit Function
End If
If biCompression <> 3 Then
Print "BMP is not compressed with then BITFIELDS method (compression=3)." ' BMP is not compressed with the BITFIELDS method (compression=3).
Close #fileNum
Load16BitBMP& = 0
Exit Function
End If
' --- [3] NaŔtenř bitfield masek (12 bajt¨) --- --- [3] Read bitfield masks (12 bytes) ---
Dim redMask As Long, greenMask As Long, blueMask As Long
Get #fileNum, , redMask
Get #fileNum, , greenMask
Get #fileNum, , blueMask
' --- [4] P°esun na zaŔßtek pixelovřch dat --- --- [4] Seek to the beginning of pixel data ---
Seek #fileNum, bfOffBits + 1
If biSizeImage = 0 Then
biSizeImage = bfSize - bfOffBits
End If
' P°etßhnýte pixelovß data jako °etýzec. Retrieve pixel data as a string.
Dim rleData As String ' zde rleData nenÝ sprßvný termÝn ľ jednß se o surovß data here, rleData is not the proper term - it is raw data.
rleData = Space$(biSizeImage)
Get #fileNum, , rleData
Close #fileNum
' --- [5] Vytvo°enř novÚho 32bit obrßzku --- --- [5] Create new 32-bit image ---
Dim newImg As Long
newImg = _NewImage(biWidth, biHeight, 32)
' ZÝskejte vřstup do pamýti novÚho obrßzku. Get output memory for the new image.
Dim newMem As _MEM
newMem = _MemImage(newImg)
' V QB64, 32bitovř obrßzek je ulo×en bez dodateŔnÚho zarovnßnÝ ľ In QB64, a 32-bit image is stored without extra alignment ľ assume row length = biWidth * 4.
' p°edpoklßdßme °ßdkovou dÚlku = biWidth * 4
Dim newRowStep As Long
newRowStep = biWidth * 4
' --- [6] Dekˇdovanř 16bitovřch pixel¨ --- --- [6] Decode 16-bit pixels ---
' V BMP jsou °ßdky ulo×eny bottom-up, tedy prvnÝ °ßdek v rleData In BMP, rows are stored bottom-up, so the first row in rleData belongs to the bottom row of the image.
' pat°Ý spodnÝmu °ßdku obrßzku.
' ěßdkovß dÚlka v souboru: Row length in the file:
Dim rowBytes As Long
rowBytes = (((biWidth * 2) + 3) \ 4) * 4
Dim x As Long, y As Long
Dim poss As Long
poss = 1
Dim fileRowData As String
Dim byte1 As _Unsigned _Byte, byte2 As _Unsigned _Byte, pixel16 As _Unsigned Integer
Dim targetRow As Long
Dim red5 As Long, green6 As Long, blue5 As Long
Dim r8 As _Unsigned _Byte, g8 As _Unsigned _Byte, b8 As _Unsigned _Byte
Dim pixel32 As _Unsigned Long
Dim offsetTarget As Long
' Pro ka×dř °ßdek obrßzku (v BMP po°adÝ: bottom-up) For each row of the image (BMP order: bottom-up)
For y = biHeight - 1 To 0 Step -1
' NaŔtýte jeden °ßdek z pixelovřch dat. Read one row of pixel data.
fileRowData = Mid$(rleData, poss, rowBytes)
poss = poss + rowBytes
' CÝlovř °ßdek v novÚm obrßzku: top-down po°adÝ Target row in the new image: top-down order
targetRow = y ' budeme uklßdat do °ßdku y; pozdýji p°Ýpadný invertovat we will store in row y; later invert if necessary
' Pro ka×dř pixel v °ßdku: For each pixel in the row:
For x = 0 To biWidth - 1
' Ka×dř pixel zabÝrß 2 bajty (little-endian) Each pixel occupies 2 bytes (little-endian)
byte1 = Asc(Mid$(fileRowData, (x * 2) + 1, 1))
byte2 = Asc(Mid$(fileRowData, (x * 2) + 2, 1))
pixel16 = byte1 Or (byte2 * 256)
' P°evod 16bit (5-6-5) na 8bit slo×ky: Convert 16-bit (5-6-5) to 8-bit components:
' Extrahujte 5bitovou Ŕervenou, 6bitovou zelenou, 5bitovou modrou. Extract 5-bit red, 6-bit green, 5-bit blue.
red5 = (pixel16 And redMask) \ redMask ' nep°esnou metodu radýji pou×ijeme posun instead of imprecise division, we'll use shifting
' P°edpoklßdejte standardnÝ masky: redMask = &HF800, greenMask = &H07E0, blueMask = &H001F. Assume standard masks: redMask = &HF800, greenMask = &H07E0, blueMask = &H001F.
' Proto: Therefore:
red5 = _ShR((pixel16 And &HF800), 11)
green6 = _ShR((pixel16 And &H07E0), 5)
blue5 = pixel16 And &H001F
' P°evod na 8bit: Convert to 8-bit:
r8 = (red5 * 255) \ 31 ' alternativný: (red5 << 3) Or (red5 >> 2)
g8 = (green6 * 255) \ 63 ' (green6 << 2) Or (green6 >> 4)
b8 = (blue5 * 255) \ 31 ' (blue5 << 3) Or (blue5 >> 2)
' Sestavte 32bitovř pixel pomocÝ _RGB: Assemble 32-bit pixel using _RGB:
pixel32 = _RGB32(r8, g8, b8)
' ZapiÜte pixel do novÚho obrßzku. Write the pixel into the new image.
' VřpoŔet offsetu v pamýti: °ßdek Calculate memory offset: row targetRow, column x.
' targetRow, sloupec x.
offsetTarget = newMem.OFFSET + (targetRow * newRowStep) + (x * 4)
_MemPut newMem, offsetTarget, pixel32 As _UNSIGNED LONG
Next x
Next y
Load16BitBMP& = newImg
End Function
In the next post, I will explain why I focused on this and also show how to easily use it.