02-17-2025, 09:39 PM
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
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
_FullScreen
'******************************************************
' 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
newC = _RGB32(NewR, NewG, NewB)
_PaletteColor c, newC, handle
a = a + 1
Loop
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?