I found a few things that _SaveFile can't do, so I'll add them here gradually. One thing every day. So first thing. Black and white BMP. Yeah. Amazing 1-bit, uncompressed BMP. In this type of BMP, compression is not supported. Maybe the compression can be partially considered the fact that each pixel in the file takes up 1 bit. The advantage of BMP over PCX is that BMP accepts any two colors.
About the program. Of course, it includes the ability to save the file. It can also open the file through its own loader, without LoadImage. There is also a image viewer (I borrowed that from my game Puzzle) and a program for setting the contrast of the input image. When setting the contrast, even thousandths matter and the output image changes rapidly. Then there is a SUB in the program for finding two suitable colors for the mask - but if you want it to be nice, you have to adjust the contrast. Of course, you can also enter the colors manually, there are only two.
Why is there a custom Loader in the program. I had an error in the file header and _LoadImage refused to open it. That's why I thought it simply didn't support it. So I wrote a loader that also smoothed the image. The result is exactly the same image as in the photo viewer. It was only when I wrote my own loader that I figured it out and fixed it. Well, never mind. My loader supports smoothing, _LoadImage doesn't. Unfortunately, smoothing comes at the expense of speed if you use large image sizes.
Code: (Select All)
'SET SOURCE IMAGE NAME (ROW 50)! BMP 1 bit Example Program
' **********************************
' Program pro uložení 1-bitové BMP
' Program for saving a 1-bit BMP
' **********************************
' --- Struktura pro BMP (File Header + Info Header + 2 maskové záznamy) ---
' --- Structure for BMP (File Header + Info Header + 2 mask records) ---
Type BW
' Header / Záhlaví
signature As String * 2 ' "BM" (konstantní signatura) "BM" (constant signature)
FileSize As Long ' Velikost souboru v bajtech File size in bytes
Res1 As Integer ' Rezervováno, nepoužito Reserved (not used)
Res2 As Integer ' Rezervováno, nepoužito Reserved (not used)
DataOffset As Long ' Offset k pixelovým datům (vždy 62 u tohoto typu BMP) Offset to pixel data (always 62 in this BMP type)
' InfoHeader / Informace o obrázku
SizeOfInfoHeader As Long ' Vždy 40 bajtů Always 40 bytes
Width As Long ' Šířka obrázku Image width
Height As Long ' Výška obrázku Image height
Planes As Integer ' Počet rovin, vždy 1 Number of planes, always 1
BitsPerPixel As Integer ' Hloubka bitů na pixel (zde 1 bit) Bits per pixel (here 1 bit)
Compression As Long ' Komprese (0 = žádná) Compression (0 = none)
ImageSize As Long ' Velikost obrázku (u nekomprimovaných obrázků je 0) Image size (0 for uncompressed)
XPixels As Long ' Horizontální rozlišení (pixely/m) Horizontal resolution (pixels per meter)
YPixels As Long ' Vertikální rozlišení (pixely/m) Vertical resolution (pixels per meter)
ColorsUsed As Long ' Použité barvy (0 = všechny z palety) Colors used (0 means all colors from palette)
ImportantColors As Long ' Důležité barvy (0 = všechny) Important colors (0 = all)
' Color table Paleta (2 záznamy pro 2 barvy obrázku)
ColorA As _Unsigned Long ' První barva (obvykle popředí) First color (usually foreground)
ColorB As _Unsigned Long ' Druhá barva (obvykle pozadí) Second color (usually background)
End Type
'******************************************************
' Hlavní program
' Main program
'******************************************************
' VERY IMPORTANT!!!
' VELMI DŮLEŽITÉ!!!
imageO = _LoadImage("6.jpg", 256) ' If you use _LoadImage xxxx.jpg, 32, go to SUB SaveBMP1 and set luminance = (77 * Red + 150 * Green + 29 * Blue) \ 256.
' Then set correct Contrast for optimal output.
' Načtení obrázku "6.jpg" - ideálně by měl být načten jako 8-bitový obrázek.
' Load the image "6.jpg" - best result when loaded as an 8-bit image.
' Tento JPG je 32-bitový; QB64PE použije vestavěnou konverzi pro nejlepší kvalitu.
' This JPG is 32-bit; QB64PE uses built-in conversion for optimal quality.
Print "Set Contrast..." ' Nastavení kontrastu obrázku Setting image contrast
SetContrast imageO, 1 '.11 ' 1 is default contrast some imeges needs Volání funkce SetContrast s hodnotou 1 Call SetContrast function with value 1
' contrast higher - try and see
Print "Detect mask colors..." ' Detekce maskovacích barev (např. černá a bílá)
' Detect mask colors (e.g., black and white) - HERE IS 5 OPTIONS for detecting mask images
If ClrsCnt(imageO) > 2 Then
DetectMaskColors imageO, 5, backGroundColor~&, foregroundColor~& ' Options in DetectMaskColors: 5 = use default mask color Black and White
' 4 = Colors with medium brightness
' 3 = Two most contrating colors
' 2 = Darkest and brightest colors
' 1 = Two most frequent colors
' Pokud obrázek obsahuje více než 2 barvy, detekuje maskovací barvy pomocí režimu 5 (černá a bílá).
' If the image has more than 2 colors, detect mask colors using mode 5 (black and white).
End If
Print "Save image..." ' Uložení obrázku jako 1-bit BMP Saving image as 1-bit BMP
SaveBMP1 imageO, "Bitmap1.bmp", foregroundColor~&, backGroundColor~&
' Uloží obrázek imageO do souboru "Bitmap1.bmp" s danými barvami popředí a pozadí.
' Save imageO to file "Bitmap1.bmp" with specified foreground and background colors.
Print "Load and make smooth...." ' Načtení BMP a aplikace vyhlazení Load BMP and apply smoothing
image = LoadAndSmoothBMP1Bit("Bitmap1.bmp")
' Načte 1-bit BMP pomocí vlastní funkce, protože _LoadImage nepodporuje 1-bitové BMP.
' Load 1-bit BMP using a custom function since _LoadImage does not accept 1-bit BMPs.
ViewImage image ' Zobrazení obrázku na obrazovce Display the image
Print "Press key for "
Print "LoadImage output."
Sleep
_FreeImage image
image = _LoadImage("Bitmap1.bmp")
ViewImage image
Print "Without Smmoothing"
Print "Press key..."
Sleep
_FreeImage imageO
Clear
End
'******************************************************
' Subrutina pro zobrazení obrázku
' Subroutine to display the image (with scaling)
'******************************************************
Sub ViewImage (Img As Long)
' Calculate the difference between image dimensions and desktop dimensions.
SpcV_DeltaW = Abs(_Width(Img) - _DesktopWidth) ' Rozdíl šířky obrázku a desktopu Difference in width between image and desktop
SpcV_DeltaH = Abs(_Height(Img) - _DesktopHeight) ' Rozdíl výšky obrázku a desktopu Difference in height between image and desktop
' Vypočítá procentuální rozdíl
' Calculate percentage difference
SpcV_PercW = SpcV_DeltaW / (_Width(Img) / 100) ' Procentuální rozdíl šířky Percentage difference in width
SpcV_PercH = SpcV_DeltaH / (_Height(Img) / 100) ' Procentuální rozdíl výšky Percentage difference in height
' Volba vyššího procenta
' Choose the higher percentage
If SpcV_PercW > SpcV_PercH Then
SpcV_P = SpcV_PercW
Else
SpcV_P = SpcV_PercH
End If
SpcV_P = SpcV_P / 100
' Výpočet konečného poměru pro změnu velikosti obrázku
' Calculate final scaling ratio for the image
If _Width(Img) > _DesktopWidth And _Height(Img) > _DesktopHeight Then
FinalRatio = 1 - SpcV_P ' Downsizing, pokud je obrázek větší ve všech směrech Downsizing if image is larger in both dimensions
End If
If _Height(Img) < _DesktopHeight And _Width(Img) < _DesktopWidth Then
FinalRatio = _DesktopHeight / _Height(Img) ' Upsizing, pokud je obrázek menší než výška desktopu Upsizing if image is smaller than desktop height
End If
If _Height(Img) > _DesktopHeight And _Width(Img) < _DesktopWidth Then
SpcV_PercH = SpcV_DeltaH / (_Height(Img) / 100)
SpcV_PercH = SpcV_PercH / 100
FinalRatio = 1 - SpcV_PercH ' Downsizing, pokud je obrázek vyšší než desktop Downsizing if image height exceeds desktop height
End If
If _Height(Img) < _DesktopHeight And _Width(Img) > _DesktopWidth Then
SpcV_PercW = SpcV_DeltaW / (_Width(Img) / 100)
SpcV_PercW = SpcV_PercW / 100
Beep
FinalRatio = 1 - SpcV_PercW ' Downsizing, pokud je obrázek širší než desktop Downsizing if image width exceeds desktop width
End If
If _Height(Img) = _DesktopHeight And _Width(Img) = _DesktopHeight Then
FinalRatio = 1 ' Pokud jsou rozměry shodné, ponech poměr 1 If dimensions match, keep scale 1
End If
' Výpočet nových rozměrů a centrování obrázku
' Calculate new dimensions and center the image on the screen
SpcV_W = FinalRatio * _Width(Img) ' Nová šířka obrázku New image width
SpcV_H = FinalRatio * _Height(Img) ' Nová výška obrázku New image height
SpcV_DeltaX = (_DesktopWidth - SpcV_W) \ 2 ' Horizontální posun pro centrování Horizontal offset to center the image
_PutImage (SpcV_DeltaX, 0)-(SpcV_DeltaX + SpcV_W, SpcV_H), Img&, 0 ' Zobrazení obrázku na přepočítané pozici a rozměrech
' Display the image at calculated position and size
End Sub
'******************************************************
' Subrutina pro nastavení kontrastu obrázku
' Subroutine to adjust image contrast
'******************************************************
Sub SetContrast (handle As Long, value)
' handle: identifikátor obrázku image handle
' value: hodnota kontrastu (0 až 5; 5 = 500% kontrastu) value in range 0 to 5; 5 means 500% contrast
Dim m As _MEM
Dim a As Long
Dim As _Unsigned Long newC
Dim As _Unsigned _Byte r, g, b, c, NewR, NewG, NewB
m = _MemImage(handle) ' Získání paměťové struktury obrázku Get the memory structure of the image
Select Case _PixelSize(handle)
Case 1 ' Pro 8-bitový obrázek (paletový) For 8 bit image
Do Until a = m.SIZE
_MemGet m, m.OFFSET + a, c ' Načtení indexu palety Retrieve palette index
r = _Red32(_PaletteColor(c, handle))
g = _Green32(_PaletteColor(c, handle))
b = _Blue32(_PaletteColor(c, handle))
' Aplikace kontrastu na jednotlivé barevné kanály
' Apply contrast adjustment on each channel
NewR = (r - 128) * value + 128
NewG = (g - 128) * value + 128
NewB = (b - 128) * value + 128
' Ošetření přetečení a podtečení (hranice 0-255)
' Clamp values to 0-255 range
If NewR > 255 Then NewR = 255
If NewR < 0 Then NewR = 0
If NewG > 255 Then NewG = 255
If NewG < 0 Then NewG = 0
If NewB > 255 Then NewB = 255
If NewB < 0 Then NewB = 0
Case 4 ' Pro 32-bitový obrázek For 32 bit image
Do Until a = m.SIZE
_MemGet m, m.OFFSET + a, b
_MemGet m, m.OFFSET + a + 1, g
_MemGet m, m.OFFSET + a + 2, r
NewR = (r - 128) * value + 128
NewG = (g - 128) * value + 128
NewB = (b - 128) * value + 128
If NewR > 255 Then NewR = 255
If NewR < 0 Then NewR = 0
If NewG > 255 Then NewG = 255
If NewG < 0 Then NewG = 0
If NewB > 255 Then NewB = 255
If NewB < 0 Then NewB = 0
_MemPut m, m.OFFSET + a, NewB
_MemPut m, m.OFFSET + a + 1, NewG
_MemPut m, m.OFFSET + a + 2, NewR
a = a + 4
Loop
End Select
End Sub
'****************************************************** Speed - up updated function - from PCX thread
' Funkce pro spočítání počtu barev v obrázku
' Function to count the number of colors in the image (8-bit and 32-bit)
'******************************************************
Function ClrsCnt (handle As Long)
' Vrátí počet unikátních barev v obrázku
' Returns the count of unique colors in the image
Dim As _Unsigned _Byte r, g, b
Dim As _MEM m
Dim As Long a, Clrscn
m = _MemImage(handle)
If _PixelSize(handle) > 1 Then
Dim c(255, 255, 255) As _Unsigned _Byte
Do Until a = m.SIZE
_MemGet m, m.OFFSET + a, b
_MemGet m, m.OFFSET + a + 1, g
_MemGet m, m.OFFSET + a + 2, r
a = a + 4
If c(r, g, b) = 0 Then
Clrscn = Clrscn + 1
c(r, g, b) = 1
End If
Loop
ClrsCnt = Clrscn
Else
Dim d(255) As _Byte
Do Until a = m.SIZE
index = _MemGet(m, m.OFFSET + a, _Unsigned _Byte)
If d(index) = 0 Then
d(index) = 1
Clrscn = Clrscn + 1
End If
a = a + 1
Loop
ClrsCnt = Clrscn
End If
End Function
'******************************************************
' Subrutina pro detekci maskovacích barev
' Subroutine to detect mask colors based on a given mode
'******************************************************
Sub DetectMaskColors (handle As Long, mode As Integer, color1 As _Unsigned Long, color2 As _Unsigned Long)
' Detekuje maskovací barvy podle zvoleného režimu
' Detects mask colors according to the selected mode
Dim m As _MEM
Dim a As Long
Dim As _Unsigned _Byte r, g, b, c, brightness
Dim colorCount(255) As Long ' Histogram pro paletový obrázek Histogram for paletted image
Dim brightnessHist(255) As Long ' Histogram světlosti Histogram for brightness
Dim totalBrightness As Long
Dim totalPixels As Long
Dim isPaletted As _Unsigned _Byte
m = _MemImage(handle)
If _PixelSize(handle) = 1 Then
isPaletted = 1 ' 8-bitový obrázek (paletový) 8-bit paletted image
' Projdeme paletové barvy
' Loop through palette colors
a = 0
Do Until a >= m.SIZE
_MemGet m, m.OFFSET + a, c ' Načtení indexu palety Get palette index
brightness = (0.3 * _Red32(_PaletteColor(c, handle)) + 0.59 * _Green32(_PaletteColor(c, handle)) + 0.11 * _Blue32(_PaletteColor(c, handle)))
brightnessHist(brightness) = brightnessHist(brightness) + 1
colorCount(c) = colorCount(c) + 1
totalBrightness = totalBrightness + brightness
totalPixels = totalPixels + 1
a = a + 1
Loop
End If
_MemFree m
If totalPixels = 0 Then totalPixels = 1 ' Ochrana proti dělení nulou Prevent division by zero
Select Case mode
Case 1 ' Nejčastější dvě barvy Two most frequent colors
Dim max1 As Long, max2 As Long, idx1 As _Unsigned _Byte, idx2 As _Unsigned _Byte
For a = 0 To 255
If colorCount(a) > max1 Then
max2 = max1
idx2 = idx1
max1 = colorCount(a)
idx1 = a
ElseIf colorCount(a) > max2 Then
max2 = colorCount(a)
idx2 = a
End If
Next
color1 = _PaletteColor(idx1, handle)
color2 = _PaletteColor(idx2, handle)
Case 2 ' Nejtmavší a nejsvětlejší barva Darkest and brightest colors
Dim minIdx As _Unsigned _Byte, maxIdx As _Unsigned _Byte
For a = 0 To 255
If brightnessHist(a) > 0 Then
minIdx = a
Exit For
End If
Next
For a = 255 To 0 Step -1
If brightnessHist(a) > 0 Then
maxIdx = a
Exit For
End If
Next
color1 = _PaletteColor(minIdx, handle)
color2 = _PaletteColor(maxIdx, handle)
Case 3 ' Nejkontrastnější dvě barvy Two most contrasting colors
Dim best1 As _Unsigned _Byte, best2 As _Unsigned _Byte, maxContrast As Long
For a = 0 To 255
For b = a + 1 To 255
Dim contrast As Long
contrast = Abs(a - b)
If contrast > maxContrast Then
maxContrast = contrast
best1 = a
best2 = b
End If
Next
Next
color1 = _PaletteColor(best1, handle)
color2 = _PaletteColor(best2, handle)
Case 4 ' Barvy se střední světlostí Colors with medium brightness
Dim middleBrightness As Long
middleBrightness = totalBrightness \ totalPixels
Dim closest1 As _Unsigned _Byte, closest2 As _Unsigned _Byte, minDiff1 As Long, minDiff2 As Long
minDiff1 = 256
minDiff2 = 256
For a = 0 To 255
Dim diff As Long
diff = Abs(a - middleBrightness)
If diff < minDiff1 Then
minDiff2 = minDiff1
closest2 = closest1
minDiff1 = diff
closest1 = a
ElseIf diff < minDiff2 Then
minDiff2 = diff
closest2 = a
End If
Next
color1 = _PaletteColor(closest1, handle)
color2 = _PaletteColor(closest2, handle)
Case 5 ' P evně nastavené: Černá a bílá Fixed mode: Black and White
color1 = _RGB32(0, 0, 0)
color2 = _RGB32(255, 255, 255)
End Select
End Sub
'*********************************************************************************************
' Subrutina pro uložení 1-bit BMP souboru
' Subroutine to save a 1-bit BMP file (uncompressed), 1Bit BMP do not support RLE compression.
'*********************************************************************************************
Sub SaveBMP1 (imageRef As Long, fileName As String, Fgc As _Unsigned Long, Bgc As _Unsigned Long)
' Parametry:
' imageRef - identifikátor obrázku image handle
' fileName - název souboru output file name
' Fgc - barva popředí (foreground) foreground color
' Bgc - barva pozadí (background) background color
Dim W As Long, H As Long, Wo As Long
Wo = _Width(imageRef) ' Původní šířka obrázku Original image width
H = _Height(imageRef) ' Výška obrázku Image height
' Uprav šířku, aby byla dělitelná 32 (nutné pro řádkové zarovnání BMP)
' Adjust width to be divisible by 32 (required for BMP row alignment)
Do Until Wo Mod 32 = 0
Wo = Wo + 1
Loop
W = Wo
' Vytvoř nový obrázek s upravenou šířkou
' Create a new image with adjusted width
Dim newImage As Long
newImage = _NewImage(W, H, 32)
Dim clr As _Unsigned Long
clr~& = &HFFFFFFFF ' Barva pozadí (např. bílá) Background color (e.g., white)
_Dest newImage
Cls , clr~&
' Zkopíruj původní obrázek do nového s novými rozměry
' Copy original image into new image with adjusted dimensions
_PutImage (0, 0), imageRef, newImage, (0, H)-(W, 0)
' (Volitelně) Uvolni původní obrázek, pokud již není potřeba
' Optionally free the original image if no longer needed:
_FreeImage imageRef
' Vypočítej celkovou velikost BMP souboru (62 bajtů = velikost záhlaví)
' Calculate total file size (header size is 62 bytes)
Dim Size As Long
Size = _Ceil(W * H / 8) + 62
' Naplň strukturu BMP hlavičky
' Fill in BMP header structure
Dim BMP1 As BW
BMP1.signature = "BM"
BMP1.FileSize = Size
BMP1.DataOffset = 62
BMP1.SizeOfInfoHeader = 40
BMP1.Width = W
BMP1.Height = H
BMP1.Planes = 1 '
BMP1.BitsPerPixel = 1 '
BMP1.Compression = 0
BMP1.ImageSize = Size - 62
BMP1.XPixels = 0
BMP1.YPixels = 0
BMP1.ColorsUsed = 0
BMP1.ImportantColors = 0
BMP1.ColorA = Fgc ' Foreground barva Foreground color
BMP1.ColorB = Bgc ' Background barva Background color
' Převod obrázku na řádky 1-bitové bitmapy (každý byte reprezentuje 8 pixelů)
' Convert the image into 1-bit bitmap data (each byte represents 8 pixels)
Dim m As _MEM
m = _MemImage(newImage)
Dim BW_Image(m.SIZE \ 8) As _Unsigned _Byte
Dim i As Long, j As Long, px As Long
i& = 0: j = 0
Do Until i& >= m.SIZE
Dim Nibble As _Unsigned _Byte
Nibble = 0
For px = 0 To 7
If i& + px + 4 > m.SIZE Then Exit Do
Dim Red As _Unsigned _Byte, Green As _Unsigned _Byte, Blue As _Unsigned _Byte
Red = _MemGet(m, m.OFFSET + i& + 3 + px * 4, _Unsigned _Byte)
Green = _MemGet(m, m.OFFSET + i& + 2 + px * 4, _Unsigned _Byte)
Blue = _MemGet(m, m.OFFSET + i& + 1 + px * 4, _Unsigned _Byte)
Dim luminance As Long
luminance = (77 * Red + 150 * Green + 29 * Blue) And 2048 'modified!
If luminance < 128 Then
Nibble = _SetBit(Nibble, 7 - px)
End If
Next
BW_Image(j) = Nibble
i& = i& + 8 * 4
j = j + 1
Loop
' Odstranění existujícího souboru, pokud již existuje
' Delete the file if it already exists
If _FileExists(fileName) Then Kill fileName
' Uložení BMP souboru do disku
' Write the BMP file to disk
Open fileName For Binary As #1
Put #1, 1, BMP1
Put #1, 63, BW_Image()
Close #1
' Uvolnění prostředků
' Free resources
ReDim BW_Image(0)
_FreeImage newImage
End Sub
'******************************************************
' Definice typů pro BMP formát
' Definitions for BMP format types
'******************************************************
Type BMPHEADER
signature As String * 2 ' "BM" – signatura souboru "BM" – file signature
filesize As Long ' Velikost souboru v bajtech File size in bytes
reserved1 As Integer ' Rezervováno Reserved (16-bit)
reserved2 As Integer ' Rezervováno Reserved (16-bit)
dataoffset As Long ' Offset k pixelovým datům Offset to pixel data
End Type
Type BMPINFOHEADER
headersize As Long ' záhlaví (obvykle 40 bajtů) Header size (usually 40 bytes)
width As Long ' Šířka obrázku Image width
height As Long ' Výška obrázku Image height
planes As Integer ' Počet rovin (vždy 1) Number of planes (always 1)
bitcount As Integer ' Hloubka bitů na pixel Bits per pixel
compression As Long ' Komprese (0 = žádná) Compression (0 = none)
imagesize As Long ' Velikost obrázku Image size
xpixels As Long ' Horizontální rozlišení Horizontal resolution
ypixels As Long ' Vertikální rozlišení Vertical resolution
colorsused As Long ' Počet barev v paletě Colors used in the palette
importantcolors As Long ' Důležité barvy Important colors
End Type
Type BMPColor
blue As _Unsigned _Byte ' Modrá složka Blue component
green As _Unsigned _Byte ' Zelená složka Green component
red As _Unsigned _Byte ' Červená složka Red component
reserved As _Unsigned _Byte ' Rezervováno Reserved
End Type
'******************************************************
' Funkce pro načtení 1-bit BMP souboru
' Function to load a 1-bit BMP file
'******************************************************
Function LoadBMP1Bit& (fileName As String)
Dim header As BMPHEADER
Dim info As BMPINFOHEADER
Dim pal(1) As BMPColor
Open fileName For Binary As #1
' Načtení BMP hlavičky (14 bajtů)
' Read BMP file header (14 bytes)
Get #1, , header
If header.signature <> "BM" Then
Print "Chyba: Soubor není BMP." ' Error: File is not a BMP.
Close #1
LoadBMP1Bit = 0
Exit Function
End If
' Načtení BITMAPINFOHEADER (40 bajtů)
' Read BITMAPINFOHEADER (40 bytes)
Get #1, , info
If info.bitcount <> 1 Then
Print "Chyba: BMP není 1bitový." ' Error: BMP is not 1-bit.
Close #1
LoadBMP1Bit = 0
Exit Function
End If
' Načtení palety (2 barvy)
' Read the color palette (2 colors)
For i = 0 To 1
Get #1, , pal(i)
Next i
' Výpočet velikosti jednoho řádku (včetně paddingu na 4 bajty)
' Calculate the size of one row (with 4-byte padding)
Dim bytesPerRow As Long
bytesPerRow = (info.width + 7) \ 8
Dim rowSize As Long
rowSize = ((bytesPerRow + 3) \ 4) * 4
Dim totalBytes As Long
totalBytes = rowSize * info.height
' Načtení pixelových dat
' Read pixel data
ReDim ddata(totalBytes - 1) As _Unsigned _Byte
Seek #1, header.dataoffset ' Nastavení pozice na začátek pixelových dat Set file pointer to pixel data offset
Get #1, , ddata()
Close #1
' Vytvoření 32-bitového obrázku pro výstup
' Create a 32-bit image for output
Dim img As Long
img = _NewImage(info.width, info.height, 32)
' Vytvoření pole pro výsledné pixely
' Create an array for the resulting pixels
ReDim pixels(info.width * info.height - 1) As _Unsigned Long
' Definice masky bitů (od MSB po LSB)
' Define bit masks (from MSB to LSB)
Dim bitMasks(7) As _Unsigned _Byte
bitMasks(0) = &H80
bitMasks(1) = &H40
bitMasks(2) = &H20
bitMasks(3) = &H10
bitMasks(4) = &H08
bitMasks(5) = &H04
bitMasks(6) = &H02
bitMasks(7) = &H01
' Rozložení pixelových dat do pole pixelů
' Decompose pixel data into pixel array
Dim y As Long, b As Long, bit As Long
Dim rowIndex As Long, rowOffset As Long, x As Long, pixelIndex As Long
Dim currentByte As _Byte
Dim col As _Unsigned Long
For y = 0 To info.height - 1
rowIndex = info.height - 1 - y ' BMP data jsou uložena zdola nahoru BMP stores rows from bottom to top
rowOffset = rowIndex * rowSize
For b = 0 To bytesPerRow - 1
currentByte = ddata(rowOffset + b)
For bit = 0 To 7
x = b * 8 + bit
If x >= info.width Then Exit For
pixelIndex = y * info.width + x
If (currentByte And bitMasks(bit)) <> 0 Then
col = _RGB32(pal(1).red, pal(1).green, pal(1).blue)
Else
col = _RGB32(pal(0).red, pal(0).green, pal(0).blue)
End If
pixels(pixelIndex) = col
Next bit
Next b
Next y
' Přenos pixelů do vytvořeného obrázku
' Copy pixel data into the image
Dim m As _MEM, n As _MEM
m = _MemImage(img)
Dim numBytes As Long
numBytes = info.width * info.height * 4
n = _Mem(pixels())
_MemCopy n, n.OFFSET, numBytes To m, m.OFFSET
_MemFree n
_MemFree m
LoadBMP1Bit = img
End Function
'******************************************************
' Funkce pro načtení 1-bit BMP a jeho vyhlazení
' Function to load a 1-bit BMP and apply smoothing (Gaussian blur)
'******************************************************
Function LoadAndSmoothBMP1Bit& (fileName As String)
Dim img As Long
img = LoadBMP1Bit(fileName) ' Načtení 1-bit BMP pomocí vlastní funkce
' Load 1-bit BMP using custom loader
If img = 0 Then
Print "Chyba při načítání BMP!" ' Error loading BMP!
Print "Error loading BMP!"
Exit Function
End If
Dim width As Long, height As Long
width = _Width(img)
height = _Height(img)
' Vytvoření nového obrázku pro vyhlazení
' Create a new image for the smoothed output
Dim smoothedImg As Long
smoothedImg = _NewImage(width, height, 32)
' Přístup k pixelovým datům
' Access pixel data of both images
Dim m As _MEM, n As _MEM, jj As _MEM
m = _MemImage(img)
n = _MemImage(smoothedImg)
' Načtení pixelových dat do pole
' Copy pixels into an array for processing
ReDim pixels(width * height - 1) As _Unsigned Long
jj = _Mem(pixels())
_MemCopy m, m.OFFSET, m.SIZE To jj, jj.OFFSET
_MemFree jj
' Vyhlazení obrázku pomocí 3×3 Gaussova filtru
' Apply smoothing using a 3x3 Gaussian filter
Dim x As Long, y As Long, i As Long, j As Long
ReDim newPixels(width * height - 1) As _Unsigned Long
' Přibližný 3×3 Gaussův filtr
' Approximate 3x3 Gaussian filter weights
Dim filter(2, 2) As Single
filter(0, 0) = 1 / 16: filter(0, 1) = 2 / 16: filter(0, 2) = 1 / 16
filter(1, 0) = 2 / 16: filter(1, 1) = 4 / 16: filter(1, 2) = 2 / 16
filter(2, 0) = 1 / 16: filter(2, 1) = 2 / 16: filter(2, 2) = 1 / 16
Dim rSum As Single, gSum As Single, bSum As Single
Dim index As Long
Dim pixelColor As _Unsigned Long
Dim r As _Unsigned _Byte, g As _Unsigned _Byte, b As _Unsigned _Byte
Dim newCol As _Unsigned Long
' Procházení obrazu (vynecháme okraje)
' Process the image excluding the borders
For y = 1 To height - 2
For x = 1 To width - 2
rSum = 0: gSum = 0: bSum = 0
' Aplikace filtru 3×3
' Apply 3x3 filter
For i = -1 To 1
For j = -1 To 1
index = (y + i) * width + (x + j)
pixelColor = pixels(index)
r = _Red32(pixelColor)
g = _Green32(pixelColor)
b = _Blue32(pixelColor)
rSum = rSum + r * filter(i + 1, j + 1)
gSum = gSum + g * filter(i + 1, j + 1)
bSum = bSum + b * filter(i + 1, j + 1)
Next j
Next i
' Uložení vyhlazeného pixelu
' Save the smoothed pixel
newCol = _RGB32(rSum, gSum, bSum)
newPixels(y * width + x) = newCol
Next x
Next y
' Kopírování vyhlazených pixelů zpět do obrázku
' Copy the smoothed pixels back into the image
Dim jjj As _MEM
jjj = _Mem(newPixels())
_MemCopy jjj, jjj.OFFSET, jjj.SIZE To n, n.OFFSET
_MemFree jjj
' Uvolnění paměti
' Free memory
_MemFree m
_MemFree n
_FreeImage img
' Výstup vyhlazeného obrázku
' Return the smoothed image
LoadAndSmoothBMP1Bit = smoothedImg
End Function
In attachments is output using _LoadImage (not smooth) and second is with my loder (smooth). Would you say it's just two colors?
So it's time for two more posts. I had problems with the second program, I finally solved it/didn't solve it - but now it works correctly even if it's not completely according to the specification.
The first program is a simple thing, saving and loading an uncompressed image into BMP in 4 bits, the number of colors for the image is a maximum of 16. The number of colors in the input image is not monitored. However, there is a function directly in the program for that, which does not monitor this, it just prints the number of colors after loading the created image.
So the first program: Uncompressed BMP 4 Bit, 16 colors:
Code: (Select All)
'--------------------------------------------------- --------------------------------------------------
'Uloží obrázek s 16 barvami jako nekomprimovaný BMP Save image in max 16 colors as uncompressed bitmap
'--------------------------------------------------- --------------------------------------------------
Screen _NewImage(1024, 768, 32)
Dim img16 As Long
img16 = _NewImage(800, 600, 256)
_Dest img16 ' create some image
For f = 0 To 15
Line (0 + 20 * f, 0 + 20 * f)-(800 - 20 * f, 600 - 20 * f), f, BF
Next
_Dest 0
outFile$ = "16-4-not_compressed.bmp"
Print "Creating uncompressed 4 bit bitmap with 16 colors..."
SaveAs4BitBMP img16, outFile$
_FreeImage img16
i = _LoadImage(outFile$, 256)
_PutImage , i
Print "File "; outFile$; " saved. _LoadImage support this format."
Print "Image use: "; ClrsCnt(i); "colors." ' Výpis informací o obrázku Print image details
Print "Image width: "; _Width(i); "Image height: "; _Height(i); "Image size: "; GetSze("outfile$"); "B Image PixelSize:"; _PixelSize(i)
Sleep
_FreeImage i
End
Function GetSze (file As String) ' Vrací velikost souboru v bajtech Returns file size in bytes
ff = FreeFile
Open file For Binary As ff
GetSze = LOF(ff)
Close ff
End Function
Sub SaveAs4BitBMP (sourceImg As Long, outputFile$) ' Uložit nekomprimovaný BMP formát (4 bit) save uncompressed BMP format (4 bit)
' Vstup: 8bitový obrázek, maximálně 16 unikátních barev. Input: 8 bit image with max 16 colors
' Výstup: BMP soubor ve 4bitovém režimu (16 barev). Output: 4 bit image with max 16 colors
Type BMP4BitHeader
signature As String * 2
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
imageSize As Long
xPelsPerMeter As Long
yPelsPerMeter As Long
colorsUsed As Long
importantColors As Long
'colorTable(15) AS _UNSIGNED LONG 16 barev (4 bajty na jednu barvu) Color palette contains 4 byte to 1 color
End Type
'===== Krok 1: Zjistíme rozměry obrázku ===== Determine image dimensions
Dim W As Long, H As Long
W = _Width(sourceImg)
H = _Height(sourceImg)
'===== Krok 2: Zjistíme, které paletové indexy se v obrázku používají ===== Determine which palette indices are used in the image
Dim memSrc As _MEM
memSrc = _MemImage(sourceImg)
Dim totalPixels As Long
totalPixels = memSrc.SIZE
' Pomocné pole – pro každý index 0..255 (0 = nepoužito, 1 = použit) Helper array – for each index 0..255 (0 = unused, 1 = used)
Dim used(0 To 255) As _Byte
Dim i As Long
Dim pixVal As _Unsigned _Byte
For i = 0 To totalPixels - 1
pixVal = _MemGet(memSrc, memSrc.OFFSET + i, _Unsigned _Byte)
used(pixVal) = 1
Next i
' Sestavíme finální paletu: pole finPal obsahuje všechny (použité) indexy Build final palette: the finPal array contains all (used) indices
Dim finPal(0 To 15) As _Unsigned _Byte
Dim usedCount As Long: usedCount = 0
Dim k As Long
For k = 0 To 255
If used(k) <> 0 Then
finPal(usedCount) = k
usedCount = usedCount + 1
If usedCount > 16 Then
Print "Input image contains more than 16 colors."
End
End If
End If
Next k
'===== Krok 3: Načteme barvy palety pomocí _PaletteColor Load palette colors using _PaletteColor
' Vytvoříme pole ColorTable, kde pro každý ze 16 indexů bude uložena 32bitová barva. Create ColorTable array, where for each of the 16 indices, a 32-bit color is stored.
Dim ColorTable(0 To 15) As _Unsigned Long
For i = 0 To 15
If i < usedCount Then
ColorTable(i) = _PaletteColor(finPal(i), sourceImg)
Else
ColorTable(i) = 0
End If
Next i
'===== Krok 4: Připravíme hlavičku BMP pro 4bitový obrázek Prepare BMP header for 4-bit image
' Definice typu BMP4BitHeader musí být již deklarována (viz váš původní kód). The BMP4BitHeader type definition must already be declared (see your original code).
Dim bmp As BMP4BitHeader
bmp.signature = "BM"
bmp.reserved1 = 0
bmp.reserved2 = 0
bmp.infoHeaderSize = 40
bmp.width = W
bmp.height = H
bmp.planes = 1
bmp.bitsPerPixel = 4
bmp.compression = 0
bmp.xPelsPerMeter = 0
bmp.yPelsPerMeter = 0
bmp.colorsUsed = 16
bmp.importantColors = 0
' V BMP se data ukládají jako řádky, kde každý pixel = 4 bity. In BMP, data is stored in rows, with each pixel equal to 4 bits.
' Počet bajtů na řádek = CEILING(W/2). Každý řádek se zarovnává na 4 bajty. Number of bytes per row = CEILING(W/2). Each row is aligned to 4 bytes.
Dim bytesPerRow As Long
bytesPerRow = (W + 1) \ 2 ' (W+1)\2 dává počet bajtů (správně funguje pro lichou i sudou šířku)
If (bytesPerRow Mod 4) <> 0 Then
bytesPerRow = bytesPerRow + (4 - (bytesPerRow Mod 4))
End If
bmp.imageSize = bytesPerRow * H
bmp.dataOffset = 14 + 40 + (16 * 4) '14 = FileHeader, 40 = InfoHeader, 64 = palette
bmp.fileSize = bmp.dataOffset + bmp.imageSize
'===== Krok 5: Převod pixelových dat z 8bitového formátu do 4bitového Convert pixel data from 8-bit format to 4-bit format.
' Vstupní obrázek obsahuje pro každý pixel jeden bajt – index do palety. Input image contains one byte per pixel – palette index.
' V BMP 4bit formátu je každý bajt složen ze dvou 4bitových hodnot (nibble). In 4-bit BMP format, each byte consists of two 4-bit values (nibbles).
' Proto potřebujeme vytvořit buffer pro pixel data. Therefore we need to create a buffer for pixel data.
Dim pixelData As String
pixelData = String$(bmp.imageSize, Chr$(0))
' Připravíme remapování – vstupní index › nový index (0 až usedCount-1) Prepare remapping – input index to new index (0 to usedCount-1)
Dim remap(0 To 255) As _Unsigned _Byte
For i = 0 To 255
remap(i) = 255 'inicializace (neplatná hodnota)
Next i
For i = 0 To usedCount - 1
remap(finPal(i)) = i
Next i
' Budeme číst obrázek po řádcích. We will read the image row by row.
'BMP ukládá řádky zdola nahoru, zatímco paměť obrázku je obvykle odshora. BMP stores rows from bottom to top, while image memory is usually top-down.
Dim outPos As Long: outPos = 0
Dim rowStr As String
Dim nibbleByte As _Unsigned _Byte
Dim x As Long, y As Long
For y = 0 To H - 1
rowStr = String$(bytesPerRow, Chr$(0))
Dim lineY As Long
lineY = H - 1 - y ' řádek v paměti obrázku Image row in memory
Dim rowOffset As Long
rowOffset = lineY * W ' protože 1 bajt na pixel
nibbleByte = 0
For x = 0 To W - 1
Dim srcIndex As Long
srcIndex = rowOffset + x
Dim pix8 As _Unsigned _Byte
pix8 = _MemGet(memSrc, memSrc.OFFSET + srcIndex, _Unsigned _Byte)
' Přemapování: získáme nový 4bitový index Remapping: obtain new 4-bit index
Dim newIndex As _Unsigned _Byte
newIndex = remap(pix8)
If (x Mod 2) = 0 Then
'Horní nibble Upper nibble
nibbleByte = _ShL(newIndex, 4)
Else
'Dolní nibble Lower nibble
nibbleByte = nibbleByte Or (newIndex And &HF)
' Uložíme bajt do řádku (pozice: (x\2)+1) Save byte into row (position: (x\2)+1)
Mid$(rowStr, (x \ 2) + 1, 1) = Chr$(nibbleByte)
nibbleByte = 0
End If
Next x
' Pokud je šířka lichá, uložíme poslední nibble: If the width is odd, store the last nibble:
If (W Mod 2) = 1 Then
Mid$(rowStr, (W \ 2) + 1, 1) = Chr$(nibbleByte)
End If
' Zkopírujeme řádek do pixelData Copy the row into pixelData.
Mid$(pixelData, outPos + 1, Len(rowStr)) = rowStr
outPos = outPos + bytesPerRow
Next y
'===== Krok 6: Zápis BMP souboru Write BMP 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: 16 barev, každý 4 bajty Palette: 16 colors, each 4 bytes
For i = 0 To 15
Put #1, , ColorTable(i)
Next i
'Pixelová data Pixel data
Put #1, , pixelData
Close #1
'Uvolnění paměťového bloku zdrojového obrázku (nebo jej ponechte, pokud se dále používá) Release the memory block of the source image (or keep it if used further)
_MemFree memSrc
End Sub
Function ClrsCnt (handle As Long)
'Vrátí počet unikátních barev v obrázku Returns the count of unique colors in the image
Dim As _Unsigned _Byte r, g, b
Dim As _MEM m
Dim As Long a, Clrscn
m = _MemImage(handle)
If _PixelSize(handle) > 1 Then
Dim c(255, 255, 255) As _Unsigned _Byte
Do Until a = m.SIZE
_MemGet m, m.OFFSET + a, b
_MemGet m, m.OFFSET + a + 1, g
_MemGet m, m.OFFSET + a + 2, r
a = a + 4
If c(r, g, b) = 0 Then
Clrscn = Clrscn + 1
c(r, g, b) = 1
End If
Loop
ClrsCnt = Clrscn
Else
Dim d(255) As _Byte
Do Until a = m.SIZE
index = _MemGet(m, m.OFFSET + a, _Unsigned _Byte)
If d(index) = 0 Then
d(index) = 1
Clrscn = Clrscn + 1
End If
a = a + 1
Loop
ClrsCnt = Clrscn
End If
End Function
Well, here's the second program. It creates an RLE - compressed 4-bit BMP file with a maximum of 16 colors. Since this format is not supported by the _LoadImage function, the program also includes a loader that loads and displays this format. The output file remains on disk, so you can check its compatibility, for example, in a photo viewer. Note the significant difference in the size of the output file compared to the previous program.
Above, I mentioned that there was a problem with the program that I solved/did not solve. If RLE encounters a point that has a different color than the points around it, it should switch to the so-called absolute encoding. The problem is that this implementation caused me to lose a part of image. Simply, after switching from RLE to absolute encoding, the rest of the image remained black. For this reason, I would like to point out that the program runs only in RLE mode, so an image that has poor content, unsuitable for RLE (that is, the image has few single-color areas and contains many small dots), the resulting size can paradoxically be much larger than in the uncompressed format. But then again, there is an option, if we know that the uncompressed version has a size of approximately (width * height)/2, then compare this number with the LOF of the resulting BMP and choose the saving method accordingly. When the problem is solved, I will update the program here and write a warning.
Code: (Select All)
'BMP - RLE4 (16 colors) for qb64pe in cooperation. Create image. Save as RLE format. Load it. Show it.
Const SCR_WIDTH = 800 ' Nastavení šířky obrazovky Set screen width
Const SCR_HEIGHT = 600 ' Nastavení výšky obrazovky Set screen height
Const DEBUG_MODE = 0 'allow = 1 Povolení ladicího režimu Enable debug mode (now is disabled)
Dim Shared debugFileNum As Integer ' Sdílená proměnná pro číslo logovacího souboru Shared variable for debug file number
If DEBUG_MODE Then ' Pokud je ladicí režim zapnutý If debug mode is enabled
debugFileNum = FreeFile ' Získání volného čísla souboru Get free file number
Open "debug.log" For Output As #debugFileNum ' Otevření logovacího souboru pro výstup Open debug.log for output
Print #debugFileNum, "=== Debug Log - Start ===" ' Zápis začátku logu Print debug log header
End If ' Konec ladicí podmínky End debug mode block
Dim img16 As Long ' Deklarace proměnné pro obrázek Declare variable for image
img16 = _NewImage(SCR_WIDTH, SCR_HEIGHT, 256) ' Vytvoření nového obrázku s 256 barvami Create a new image with 256 colors
_Dest img16 ' Nastavení cílového obrázku ' Set destination image
Cls , 4 ' Vyčištění obrazovky s barvou 4 Clear screen with color 4
Locate 10, 1 ' Nastavení pozice kurzoru Set cursor position
For f = 0 To 15 ' Smyčka přes 16 barev Loop over 16 colors
Line (0 + 20 * f, 0 + 20 * f)-(800 - 20 * f, 600 - 20 * f), f, BF
Next ' Konec smyčky End loop
_PrintMode _KeepBackground ' Nastavení režimu tisku tak, aby se zachovalo pozadí Set print mode to keep background
Color 0 ' Nastavení barvy textu na 0 Set text color to 0
Print ' Vytisknutí prázdného řádku Print blank line
Print " Hi QB64PE Team. I am your first RLE - compressed 16 colors bitmap!"
Print " Because _LoadImage can't load my format, is used own loader!"
_Dest 0
Print "Saving image to file 'testRLE4.bmp'"
Sleep 2
SaveAs4BitRLEBMP img16, "testRLE4.bmp"
Dim loadedImg As Long
loadedImg = _LoadImage("testRLE4.bmp", 256) ' Load image using built-in _LoadImage (always failure, but you can test bmp file with windows photo viewer)
Screen _NewImage(800, 600, 32)
Print "Hm... Returned by _LoadImage: "; loadedImg
Sleep 2
image& = Load4BitRLEBMP("testRLE4.bmp") ' Načtení obrázku pomocí vlastního loaderu Load image using custom loader
_PutImage , image& ' Zobrazení načteného obrázku Display the loaded image
Print "So use own loader..." '
Print "Image width: "; _Width(image&); "Image height: "; _Height(image&); "Image size: "; GetSze("testRLE4.bmp"); "B Image PixelSize:"; _PixelSize(image&) ' Výpis informací o obrázku ' Print image details
Sleep
If DEBUG_MODE Then
Print #debugFileNum, "=== Debug Log - Konec ===" ' Výpis konce logu Print debug log end
Close #debugFileNum ' Zavření logovacího souboru Close debug file
End If ' Konec ladicí podmínky End debug mode block
' ============================================================
' Typ BMP4BitHeader ' BMP header type definition
' ============================================================
Type BMP4BitHeader ' Definice struktury BMP hlavičky Define BMP header structure
signature As String * 2 ' Podpis BMP souboru ("BM") BMP file signature ("BM")
fileSize As Long ' Celková velikost souboru Total file size
reserved1 As Integer ' Rezervované pole Reserved field 1
reserved2 As Integer ' Rezervované pole Reserved field 2
dataOffset As Long ' Offset, kde začínají obrazová data Data offset from file start
infoHeaderSize As Long ' Velikost informační hlavičky Info header size
width As Long ' Šířka obrázku Image width
height As Long ' Výška obrázku Image height
planes As Integer ' Počet rovin (vždy 1) Number of planes (always 1)
bitsPerPixel As Integer ' Bity na pixel Bits per pixel
compression As Long ' Typ komprese (pro RLE4: 2) Compression type (RLE4: 2)
imageSize As Long ' Velikost obrazových dat Image data size
xPelsPerMeter As Long ' Horizontální rozlišení Horizontal resolution
yPelsPerMeter As Long ' Vertikální rozlišení Vertical resolution
colorsUsed As Long ' Počet použitých barev Colors used
importantColors As Long ' Počet důležitých barev Important colors
End Type ' Konec definice BMP4BitHeader End BMP4BitHeader definition
' ============================================================
' Funkce: GetSze
' ============================================================
Function GetSze (file As String) ' Vrací velikost souboru v bajtech Returns file size in bytes
ff = FreeFile
Open file For Binary As ff
GetSze = LOF(ff)
Close ff '
End Function '
' ============================================================
' SUB: SaveAs4BitRLEBMP ' Sub: SaveAs4BitRLEBMP
' ============================================================
Sub SaveAs4BitRLEBMP (sourceImg As Long, outputFile$) ' Uloží obrázek ve formátu 4-bit BMP s RLE4 kompresí Save image in 4-bit BMP with RLE4 compression
Dim w As Long, h As Long ' Deklarace proměnných pro rozměry obrázku Declare image dimension variables
w = _Width(sourceImg) ' Získání šířky obrázku Get image width
h = _Height(sourceImg) ' Získání výšky obrázku Get image height
Dim totalPixels As Long ' Celkový počet pixelů Total number of pixels
totalPixels = w * h ' Výpočet celkového počtu pixelů Calculate total pixels
Dim memSrc As _MEM ' Paměťová oblast zdrojového obrázku Source image memory block
memSrc = _MemImage(sourceImg) ' Získání paměťové oblasti Get image memory block
Dim used(0 To 255) As _Unsigned _Byte ' Pole pro použití barev Array to track used colors
Dim i As Long
For i = 0 To 255 ' Inicializace pole pro 256 barev Initialize used array for 256 colors
used(i) = 0 ' Nastavení hodnoty na 0 Set to 0
Next i
Dim tVal As _Unsigned _Byte
For i = 0 To totalPixels - 1 ' Pro každý pixel v obrázku For each pixel in image
tVal = _MemGet(memSrc, memSrc.OFFSET + i, _Unsigned _Byte) ' Načtení hodnoty pixelu Get pixel value
used(tVal) = 1 ' Označení, že barva byla použita Mark color as used
Next i
Dim finPal(0 To 15) As _Unsigned _Byte ' Finální paleta (max 16 barev) Final palette (max 16 colors)
Dim usedCount As Long: usedCount = 0 ' Počet použitých barev Count of used colors
Dim c As Long
For c = 0 To 255 ' Pro každou barvu For each color
If used(c) <> 0 Then ' Pokud je barva použita If color is used
finPal(usedCount) = c ' Uložení barvy do finální palety Save color to final palette
usedCount = usedCount + 1 ' Zvýšení počtu použitých barev Increment used color count
If usedCount > 16 Then ' Pokud je více než 16 barev If more than 16 colors
Print "Input image has more than 16 colors!" ' Chybová hláška Error message
End ' Ukončení programu ' End program
End If
End If
Next c
Dim remap(0 To 255) As _Unsigned _Byte ' Remapovací pole pro změnu indexů barev Remapping array for color indices
For i = 0 To 255
remap(i) = 255 ' Inicializace remapovacího pole Initialize remap array
Next i
For i = 0 To usedCount - 1 ' Pro každou použitou barvu For each used color
remap(finPal(i)) = i ' Přiřazení nového indexu Assign new index
Next i
Dim ColorTable(0 To 15) As _Unsigned Long ' Tabulka barev pro BMP Color table for BMP
For i = 0 To 15
If i < usedCount Then
ColorTable(i) = _PaletteColor(finPal(i), sourceImg) ' Načtení barvy z palety zdroje Get color from source palette
Else
ColorTable(i) = 0 ' Nepoužité barvy nastavit na 0 Set unused colors to 0
End If
Next i
Dim bmp As BMP4BitHeader ' Deklarace struktury BMP hlavičky Declare BMP header structure
bmp.signature = "BM" ' Nastavení podpisu BMP Set BMP signature
bmp.reserved1 = 0 ' Rezervované pole Reserved field 1
bmp.reserved2 = 0 ' Rezervované pole Reserved field 2
bmp.infoHeaderSize = 40 ' Velikost informační hlavičky Info header size
bmp.width = w ' Šířka obrázku Image width
bmp.height = h ' Výška obrázku Image height
bmp.planes = 1 ' Počet rovin Number of planes
bmp.bitsPerPixel = 4 ' Bity na pixel Bits per pixel
bmp.compression = 2 ' RLE4 komprese RLE4 compression
bmp.xPelsPerMeter = 0 ' Horizontální rozlišení Horizontal resolution
bmp.yPelsPerMeter = 0 ' Vertikální rozlišení Vertical resolution
bmp.colorsUsed = 16 ' Počet barev v paletě Number of colors used
bmp.importantColors = 0 ' Všechny barvy jsou důležité All colors are important
Dim rowPitch As Long ' Výpočet délky řádku v bajtech Calculate row pitch in bytes
rowPitch = ((w + 3) \ 4) * 4 ' Zarovnání řádku na 4 bajty Align row to 4 bytes
Dim indexArray(0 To totalPixels - 1) As _Unsigned _Byte ' Pole indexů pixelů Array for pixel indices
Dim pixPos As Long: pixPos = 0 ' Počáteční pozice v indexArray Starting index position
Dim y As Long, x As Long
For y = 0 To h - 1 ' Smyčka přes všechny řádky Loop through all rows
Dim srcY As Long
srcY = (h - 1) - y ' BMP řádky jsou uloženy odspodu nahoru BMP rows are stored bottom-up
Dim rowOff As Long
rowOff = srcY * rowPitch ' Výpočet offsetu řádku v paměti Calculate row offset in memory
For x = 0 To w - 1 ' Smyčka přes všechny sloupce Loop through all columns
Dim p8 As _Unsigned _Byte
p8 = _MemGet(memSrc, memSrc.OFFSET + rowOff + x, _Unsigned _Byte) ' Načtení pixelu ze zdrojového obrázku Get pixel from source image
indexArray(pixPos) = remap(p8) ' Remapování původního indexu na nový Remap original pixel index
pixPos = pixPos + 1 ' Posun v indexArray Increment index position
Next x
Next y
Dim rleData As String: rleData = "" ' Inicializace řetězce pro RLE data Initialize string for RLE data
Dim rowOfs As Long: rowOfs = 0 ' Offset pro každý řádek v indexArray Row offset in indexArray
For y = 1 To h ' Smyčka přes každý řádek Loop for each row
Dim rowStr As String
rowStr = CompressRowRLE4(indexArray(), rowOfs, w) ' Komprimace řádku do RLE4 Compress row using RLE4
rleData = rleData + rowStr ' Přidání komprimovaného řádku do výsledného řetězce Append compressed row data
rleData = rleData + Chr$(0) + Chr$(0) ' Zápis konec řádku (0,0) Write end-of-line marker (0,0)
rowOfs = rowOfs + w ' Posun na další řádek v indexArray Move to next row in index array
Next y
rleData = rleData + Chr$(0) + Chr$(1) ' Zápis ukončovacího příkazu (0,1) Write end-of-bitmap marker (0,1)
bmp.imageSize = Len(rleData) ' Nastavení velikosti obrazových dat Set image data size
bmp.dataOffset = 14 + 40 + (16 * 4) ' Výpočet offsetu dat (hlavička + paleta) Calculate data offset (header + palette)
bmp.fileSize = bmp.dataOffset + bmp.imageSize ' Výpočet celkové velikosti souboru Calculate total file size
_MemFree memSrc ' Uvolnění paměti zdrojového obrázku Free memory of source image
If _FileExists(outputFile$) Then Kill outputFile$ ' Smazání existujícího souboru, pokud existuje Delete existing file if any
Dim fileNum As Integer: fileNum = FreeFile ' Získání volného čísla souboru pro zápis Get free file number for output
Open outputFile$ For Binary As #fileNum ' Otevření souboru pro binární zápis Open output file for binary writing
Put #fileNum, , bmp.signature ' Zápis podpisu BMP do souboru Write BMP signature to file
Put #fileNum, , bmp.fileSize ' Zápis celkové velikosti souboru Write total file size
Put #fileNum, , bmp.reserved1 ' Zápis rezervovaných bajtů Write reserved field 1
Put #fileNum, , bmp.reserved2 ' Zápis rezervovaných bajtů Write reserved field 2
Put #fileNum, , bmp.dataOffset ' Zápis offsetu dat Write data offset
Put #fileNum, , bmp.infoHeaderSize ' Zápis velikosti informační hlavičky Write info header size
Put #fileNum, , bmp.width ' Zápis šířky obrázku Write image width
Put #fileNum, , bmp.height ' Zápis výšky obrázku Write image height
Put #fileNum, , bmp.planes ' Zápis počtu rovin Write number of planes
Put #fileNum, , bmp.bitsPerPixel ' Zápis bitů na pixel Write bits per pixel
Put #fileNum, , bmp.compression ' Zápis typu komprese Write compression type
Put #fileNum, , bmp.imageSize ' Zápis velikosti obrazových dat Write image data size
Put #fileNum, , bmp.xPelsPerMeter ' Zápis horizontálního rozlišení Write horizontal resolution
Put #fileNum, , bmp.yPelsPerMeter ' Zápis vertikálního rozlišení Write vertical resolution
Put #fileNum, , bmp.colorsUsed ' Zápis počtu použitých barev Write number of colors used
Put #fileNum, , bmp.importantColors ' Zápis počtu důležitých barev Write number of important colors
For i = 0 To 15 ' Smyčka pro zápis palety Loop to write palette
Put #fileNum, , ColorTable(i) ' Zápis barvy z palety Write palette color
Next i
Put #fileNum, , rleData ' Zápis RLE4 dat Write RLE4 compressed data
Close #fileNum ' Zavření souboru Close file
End Sub
' ============================================================ ' ============================================================
' Funkce: CompressRowRLE4 – s okamžitým flushováním, když runLen=1 ' Function: CompressRowRLE4 – immediate flush when runLen=1
' ============================================================ ' ============================================================
Function CompressRowRLE4$ (rowNibbles() As _Unsigned _Byte, start As Long, rowWidth As Long)
Dim result As String: result = "" ' Inicializace výsledného řetězce Initialize result string
Dim maxIndex As Long: maxIndex = UBound(rowNibbles) ' Zjištění maximálního indexu v poli Get maximum index of array
Dim i As Long: i = 0 ' Počáteční index ' Initialize index to 0
If DEBUG_MODE Then Print #debugFileNum, "=== Zpracování řádku, start=", start, " rowWidth=", rowWidth ' Debug: start row processing Debug: row processing start
Do While i < rowWidth ' Smyčka přes pixely v řádku Loop through pixels in row
If (start + i) > maxIndex Then Exit Do ' Pokud jsme mimo pole, ukončíme Exit if index exceeds array bounds
Dim currentVal As _Unsigned _Byte: currentVal = rowNibbles(start + i) ' Načtení aktuální hodnoty nibble Get current nibble value
If DEBUG_MODE Then Print #debugFileNum, "i=", i, " currentVal=", currentVal ' Debug: tisk aktuální hodnoty Debug: print current value
Dim runLen As Long: runLen = 1 ' Inicializace délky opakování Initialize run length
Dim j As Long: j = i + 1 ' Nastavení dalšího indexu pro porovnání Set index for comparison
Do While (j < rowWidth) And ((start + j) <= maxIndex)
If rowNibbles(start + j) <> currentVal Then Exit Do ' Pokud se hodnota liší, ukončíme smyčku Exit if nibble differs
runLen = runLen + 1 ' Zvýšení délky opakování Increment run length
If runLen >= 255 Then Exit Do ' Limit délky opakování na 255 Limit run length to 255
j = j + 1 ' Posun indexu ' Increment index
Loop
If DEBUG_MODE Then Print #debugFileNum, "i=", i, " Detekován run s currentVal=", currentVal, " runLen=", runLen ' Debug: tisk zjištěného runu Debug: print run detected
' Zpracování kódovaného (run) bloku
If runLen >= 1 Then
Dim remain As Long: remain = runLen ' N astavení zbývající délky Set remaining run length
Do While remain > 255
result = result + Chr$(255) + Chr$(_ShL(currentVal, 4) Or currentVal) ' Zápis bloku s 255 opakováními Write block of 255 repeats
If DEBUG_MODE Then Print #debugFileNum, "Zapsán run blok: délka=255, currentVal=", currentVal ' Debug: tisk zapsaného bloku Debug: print block written
remain = remain - 255 ' Odečtení 255 opakování ' Subtract 255 from run length
Loop
result = result + Chr$(remain) + Chr$(_ShL(currentVal, 4) Or currentVal) ' Zápis zbývajícího run bloku Write remaining run block
If DEBUG_MODE Then Print #debugFileNum, "Zapsán run blok: délka=", remain, " currentVal=", currentVal ' Debug: tisk posledního bloku Debug: print last block
i = i + runLen ' Posun indexu o délku runu Increment index by run length
End If
Loop
If DEBUG_MODE Then Print #debugFileNum, "=== Konec zpracování řádku ===" ' Debug: konec zpracování řádku Debug: end of row processing
CompressRowRLE4 = result ' Vrácení komprimovaného řádku Return compressed row string
End Function
' ============================================================
' Funkce: FlushAbsoluteBlock
' ============================================================
Function FlushAbsoluteBlock$ (absData As String, absCount As Long)
Dim ut As String: ut = "" ' Inicializace výstupního řetězce Initialize output string
ut = ut + Chr$(0) + Chr$(absCount) ' Zápis značky absolutního bloku a délky Write absolute block marker and length
Dim tmp As String: tmp = "" ' Dočasný řetězec pro kombinaci nibblů Temporary string for combined nibbles
Dim n As Long: n = 1 ' Počáteční index Initialize index to 1
Do While n <= Len(absData) ' Smyčka přes absolutní data Loop through absolute data
Dim nib1 As _Unsigned _Byte: nib1 = Asc(Mid$(absData, n, 1)) ' Načtení prvního nibble Get first nibble
Dim nib2 As _Unsigned _Byte: nib2 = 0 ' Inicializace druhého nibble Initialize second nibble
If (n + 1) <= Len(absData) Then nib2 = Asc(Mid$(absData, n + 1, 1)) ' Načtení druhého nibble, pokud existuje Get second nibble if available
Dim combined As _Unsigned _Byte: combined = _ShL((nib1 And &HF), 4) Or (nib2 And &HF) ' Kombinace dvou nibblů do jednoho bajtu Combine two nibbles into one byte
tmp = tmp + Chr$(combined) ' Přidání kombinovaného bajtu do dočasného řetězce Append combined byte to temporary string
n = n + 2 ' Posun indexu o 2 Increment index by 2
Loop
ut = ut + tmp ' Připojení kombinovaných bajtů k výstupnímu řetězci Append combined bytes to output
Dim byteCount As Long: byteCount = (absCount + 1) \ 2 ' Výpočet počtu bajtů v absolutním bloku Calculate number of bytes in absolute block
If (byteCount Mod 2) = 1 Then ut = ut + Chr$(0) ' Přidání padovacího bajtu, pokud je počet bajtů lichý Add padding byte if odd number of bytes
FlushAbsoluteBlock = ut ' Vrácení výsledného absolutního bloku Return absolute block string
End Function
' ============================================================
' Funkce: Load4BitRLEBMP
' ============================================================
' Načte BMP soubor s RLE4 kompresí, který byl vytvořen pomocí našeho SaveAs4BitRLEBMP.
' POZN.: Tento loader používá stejnou “podmínku”, jakou má náš save routine – tedy vždy, když je bajt count nenulový,
' je to kódovaný blok (run block), i kdyby count=1, což není úplně podle standardní specifikace - ale funguje správnš.
' Loads a BMP file with RLE4 compression produced by our save routine.
' NOTE: This loader uses the same condition as our save routine – if the count byte is nonzero,
' it treats the block as a run block (even if count=1), which is non-standard - but works correctly.
Function Load4BitRLEBMP& (fileName$)
' Otevře BMP soubor, načte hlavičku, paletu a RLE4 data a dekóduje je do nového obrázku.
' Opens the BMP file, reads header, palette, and RLE4 data, and decodes them into a new image.
Dim fileNum As Integer: fileNum = FreeFile ' Získání volného čísla souboru Get free file number
Open fileName$ For Binary As #fileNum ' Otevření BMP souboru pro binární čtení Open BMP file for binary reading
' Načtení hlavičky (14 bajtů)
Dim signature As String * 2 ' BMP podpis BMP signature
Dim fileSize As Long, reserved1 As Integer, reserved2 As Integer, dataOffset As Long ' Hlavičková data Header data
Get #fileNum, , signature ' Čtení podpisu Read signature
If signature <> "BM" Then ' Kontrola podpisu Verify signature
Print "Není to BMP soubor!" ' Chybová zpráva Error: Not a BMP file
Close #fileNum ' Zavření souboru Close file
Load4BitRLEBMP = 0 ' Vrácení 0 jako chyba Return 0 as error
Exit Function
End If
Get #fileNum, , fileSize ' Čtení celkové velikosti souboru Read total file size
Get #fileNum, , reserved1 ' Čtení rezervovaných bajtů Read reserved field 1
Get #fileNum, , reserved2 ' Čtení rezervovaných bajtů Read reserved field 2
Get #fileNum, , dataOffset ' Čtení offsetu dat Read data offset
' Načtení BITMAPINFOHEADER (40 bajtů)
Dim infoHeaderSize As Long, width As Long, height As Long ' Data hlavičky obrázku Image header data
Dim planes As Integer, bitsPerPixel As Integer, compression As Long ' Další hlavičková data Additional header info
Dim imageSize As Long, xPelsPerMeter As Long, yPelsPerMeter As Long ' Velikost dat a rozlišení Image size and resolution
Dim colorsUsed As Long, importantColors As Long ' Počet použitých a důležitých barev Colors used and important colors
Get #fileNum, , infoHeaderSize ' Čtení velikosti informační hlavičky Read info header size
Get #fileNum, , width ' Čtení šířky obrázku Read image width
Get #fileNum, , height ' Čtení výšky obrázku Read image height
Get #fileNum, , planes ' Čtení počtu rovin Read number of planes
Get #fileNum, , bitsPerPixel ' Čtení bitů na pixel Read bits per pixel
Get #fileNum, , compression ' Čtení typu komprese Read compression type
Get #fileNum, , imageSize ' Čtení velikosti obrazových dat Read image data size
Get #fileNum, , xPelsPerMeter ' Čtení horizontálního rozlišení Read horizontal resolution
Get #fileNum, , yPelsPerMeter ' Čtení vertikálního rozlišení Read vertical resolution
Get #fileNum, , colorsUsed ' Čtení počtu použitých barev Read number of colors used
Get #fileNum, , importantColors ' Čtení počtu důležitých barev Read number of important colors
If bitsPerPixel <> 4 Then ' Kontrola, zda se jedná o 4-bit BMP Verify image is 4-bit
Print "Nejedná se o 4-bit BMP!" ' Chybová zpráva Error: Not a 4-bit BMP
Close #fileNum ' Zavření souboru Close file
Load4BitRLEBMP = 0 ' Vrácení 0 jako chybu Return 0 as error
Exit Function
End If
' Načtení palety – 16 barev, každý 4 bajty (B, G, R, 0)
Dim pal(0 To 15) As _Unsigned Long ' Deklarace palety pro 16 barev Declare palette for 16 colors
Dim i As Long
For i = 0 To 15 ' Smyčka pro 16 barev Loop for 16 colors
Dim blue As _Unsigned _Byte, green As _Unsigned _Byte, red As _Unsigned _Byte, reserved As _Unsigned _Byte
Get #fileNum, , blue ' Načtení modré složky Read blue component
Get #fileNum, , green ' Načtení zelené složky Read green component
Get #fileNum, , red ' Načtení červené složky Read red component
Get #fileNum, , reserved ' Načtení rezervovaného bajtu Read reserved byte
pal(i) = red * 65536 + green * 256 + blue ' Sestavení barvy ve formátu &H00RRGGBB Construct color as &H00RRGGBB
Next i
' Přesunutí čtecí pozice na začátek obrazových dat Seek to start of image data
Seek #fileNum, dataOffset + 1 ' Použití dataOffset + 1 (kvůli 1-indexování) Use dataOffset + 1 for 1-indexing
' Načtení RLE dat Read RLE data
Dim rleData As String
rleData = Space$(imageSize) ' Inicializace řetězce pro RLE data Initialize RLE data string
Get #fileNum, , rleData ' Načtení RLE dat do řetězce Read RLE data
Close #fileNum ' Zavření souboru Close file
' Vytvoření nového obrázku s rozměry width x height Create new image with dimensions from header
Dim img As Long
img = _NewImage(width, height, 256) ' Vytvoření 256barevného obrázku Create a 256-color image
For i = 0 To 15 ' Smyčka pro nastavení palety Loop to set palette
_PaletteColor i, pal(i), img ' Nastavení palety obrázku Set image palette color
Next i
' Získání paměťové oblasti nového obrázku Get memory block for image
Dim memImg As _MEM
memImg = _MemImage(img)
' Výpočet řádkové délky v bajtech Calculate row pitch in bytes
Dim rowPitch As Long
rowPitch = ((width + 3) \ 4) * 4 ' Zarovnání řádků na 4 bajty Align rows to 4 bytes
' Dekódování RLE dat – BMP ukládá řádky odspodu nahoru Decode RLE data – BMP rows stored bottom-up
Dim curRow As Long: curRow = 0 ' Počáteční řádek Initialize current row to 0
Dim curCol As Long: curCol = 0 ' Počáteční sloupec Initialize current column to 0
Dim poss As Long: poss = 1 ' Počáteční pozice v RLE datech Start position in RLE data
Dim dataLen As Long: dataLen = Len(rleData) ' Celková délka RLE dat Total length of RLE data
Do While poss <= dataLen ' Smyčka přes RLE data Loop through RLE data
Dim countByte As _Unsigned _Byte, dataByte As _Unsigned _Byte
countByte = Asc(Mid$(rleData, poss, 1)) ' Načtení count bajtu Read count byte
poss = poss + 1 ' Posun o 1 bajt Increment position by 1
If poss > dataLen Then Exit Do
dataByte = Asc(Mid$(rleData, poss, 1)) ' Načtení datového bajtu Read data byte
poss = poss + 1 ' Posun o 1 bajt Increment position by 1
If countByte = 0 Then ' Speciální příkazy Special commands
If dataByte = 0 Then ' Konec řádku End of line
curRow = curRow + 1 ' Zvýšení řádku Increment row
curCol = 0 ' Reset sloupce Reset column
ElseIf dataByte = 1 Then ' Konec bitmapy End of bitmap
Exit Do ' Ukončení dekódování Exit decoding loop
ElseIf dataByte = 2 Then ' Delta příkaz (posun) Delta command (shift)
If poss + 1 > dataLen Then Exit Do
Dim dx As _Unsigned _Byte, dy As _Unsigned _Byte
dx = Asc(Mid$(rleData, poss, 1)) ' Delta – posun v x Delta shift in x
dy = Asc(Mid$(rleData, poss + 1, 1)) ' Delta – posun v y Delta shift in y
poss = poss + 2 ' Posun o 2 bajty Increment position by 2
curCol = curCol + dx ' Aktualizace sloupce Update column
curRow = curRow + dy ' Aktualizace řádku Update row
Else ' Absolutní blok Absolute block
Dim absCount As Long: absCount = dataByte ' Počet nibble v absolutním bloku Number of nibbles in absolute block
Dim byteCount As Long: byteCount = (absCount + 1) \ 2 ' Počet bajtů v absolutním bloku Number of bytes in absolute block
Dim absData As String
absData = Mid$(rleData, poss, byteCount) ' Načtení absolutních dat Read absolute block data
poss = poss + byteCount ' Posun za absolutní data Move position past absolute data
Dim k As Long
For k = 1 To absCount ' Smyčka přes nibble v absolutním bloku Loop through each nibble in absolute block
Dim currentNibble As _Unsigned _Byte
Dim currentByte As _Unsigned _Byte: currentByte = Asc(Mid$(absData, ((k + 1) \ 2), 1))
If (k Mod 2) = 1 Then
currentNibble = currentByte \ 16 ' Horní nibble Upper nibble
Else
currentNibble = currentByte And &HF ' Dolní nibble Lower nibble
End If
_MemPut memImg, memImg.OFFSET + (((height - curRow - 1) * rowPitch) + curCol), currentNibble As _UNSIGNED _BYTE ' Zápis pixelu Write pixel to image memory
curCol = curCol + 1 ' Posun sloupce Increment column
If curCol >= width Then Exit For ' Pokud konec řádku, ukončit smyčku Exit loop if end of row
Next k
End If
Else ' Kódovaný režim (run mode) Encoded (run) mode
Dim j As Long
For j = 1 To countByte ' Smyčka přes počet opakování Loop for count repetitions
Dim pixel As _Unsigned _Byte
If (j Mod 2) = 1 Then
pixel = dataByte \ 16 ' Horní nibble Upper nibble
Else
pixel = dataByte And &HF ' Dolní nibble Lower nibble
End If
_MemPut memImg, memImg.OFFSET + (((height - curRow - 1) * rowPitch) + curCol), pixel As _UNSIGNED _BYTE ' Zápis pixelu do obrázku Write pixel to image memory
curCol = curCol + 1 ' Posun sloupce Increment column
If curCol >= width Then Exit For ' Ukončení smyčky při dosažení konce řádku Exit loop if end of row reached
Next j
End If
' Automatický posun řádku se zde neprovádí, protože konec řádku je explicitně signalizován (0,0 nebo delta)
If curRow >= height Then Exit Do ' Pokud jsou všechny řádky načteny, ukončíme dekódování Exit loop if all rows processed
Loop
Load4BitRLEBMP = img ' Vrácení načteného obrázku Return the loaded image
End Function
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:
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 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.
