So here is the final form. All together, the whole thing is controlled by two subroutines. SaveBMP and LoadBMP. The goal was (apart from fun) to achieve automatic selection of the BMP format. If saving to BMP, it is not always necessary to use the highest format. So I added a function that detects the efficiency of RLE compression before compression and depending on that (if PixelSize is 1 and the condition of the number of colors for RLE4 or RLE8 is met) it is determined whether to save to RLE format or save to uncompressed to 8-bit BMP. The same in the case of 32-bit images. If the number of colors is <=65535, it is saved to 16-bit format, otherwise _SaveImage is used.
In order to be able to view all BMPs directly, there is also LoadBMP that displays some formats using subroutines that are already published above and takes the rest from _LoadImage. After loading the image, it is first displayed as it was loaded, and after pressing a key, it is shown as it looks after passing through the filter.
The attached image contains only 9 colors. It shows the filter's work nicely. (if you save it in the program)
In order to be able to view all BMPs directly, there is also LoadBMP that displays some formats using subroutines that are already published above and takes the rest from _LoadImage. After loading the image, it is first displayed as it was loaded, and after pressing a key, it is shown as it looks after passing through the filter.
Code: (Select All)
' An example of why I focused on the details of the BMP format.
' 1) I enjoy it
' 2) It is possible to reduce the size of a BMP without losing quality if you save the image with
' a certain number of colors, a certain bit depth and a certain compression option. The program
' will assess all this and choose the best BMP format so that the quality is preserved while keeping
' the BMP size as small as possible. Sure. You might say - I'll use PNG. Yes. But this here is just about BMP.
Dim As Long I, J
I = _LoadImage("66-16.png", 256)
SaveBMP I, "test4.bmp"
_FreeImage I
J = LoadBMP("test4.bmp") 'LoadBMP - you can see supported and also unsupported BMP formats.
'for smooth image - else use J
w = _Width(J)
h = _Height(J)
N = _NewImage(w, h, 32)
_PutImage , J, N
boxBlur3x3 N
'_FreeImage J
Screen J
_FullScreen
Print "Press key for filtered output"
Sleep
Screen N
_FullScreen
Print "Press key for end"
Sleep
Screen 0
_FreeImage I
_FreeImage N
System
Function LoadBMP (FileName As String)
If LCase$(Right$(FileName, 4)) <> ".bmp" Then FileName = FileName + ".bmp"
If _FileExists(FileName) Then
Dim BMPh As BMPFileHeader
Dim BMPi As BMPInfoHeader
ff = FreeFile
Open FileName For Binary As ff
Get ff, , BMPh
Get ff, , BMPi
Close ff
If BMPi.biBitCount = 16 And BMPi.biCompression = 3 Then LoadBMP = Load16BitBMP555(FileName): Exit Function
If BMPi.biBitCount = 4 And BMPi.biCompression = 2 Then LoadBMP = Load4BitRLEBMP(FileName): Exit Function
If BMPi.biBitCount = 8 And BMPi.biCompression = 1 Then LoadBMP = Load8BitRLEBMP(FileName): Exit Function
If BMPi.biBitCount = 1 And BMPi.biCompression = 0 Then LoadBMP = LoadAndSmoothBMP1Bit(FileName): Exit Function
LoadBMP = _LoadImage(FileName, 32)
Else
f = _MessageBox("Error", "Load BMP error. File " + FileName + "not found. ", "ok", "error", 1)
End 'Exit Function
End If
End Function
Sub SaveBMP (handle As Long, ToFile As String)
If LCase$(Right$(ToFile, 4)) <> ".bmp" Then ToFile = ToFile + ".bmp"
Dim As _Byte Warn
Dim As Long ColorCount
If _FileExists(ToFile) Then
Warn = _MessageBox("Warnig", "File " + ToFile$ + " exsist. Overwrite it? ", "yesno", "warning", 0)
If Warn = 0 Then End 'Exit Sub
End If
If handle > -2 Then
Warn = _MessageBox("Error", "Save BMP error. Image Handle has not valid value. ", "ok", "error", 1)
End 'Exit Sub
End If
Dim RleSze As Long
ColorCount = ClrsCnt(handle)
Print "Image colors: "; ColorCount
Sleep 1
Select Case _PixelSize(handle)
Case 4 ' Source is 32 bit image
Select Case ColorCount
Case Is <= 65535
'ulozit do 16 bitoveho BMP
Save16BitBMP555 handle, ToFile
Case Else
'ulozit do _SaveImage BMP (32 bit)
_SaveImage ToFile, handle
End Select
Case 1 ' Source is 8 bit image
Select Case ColorCount
Case Is < 3
W = _Width(handle)
H = _Height(handle)
Not_Needed = EfficiencyRLE(handle, 4, RleSze)
If (W * H) \ 8 > RleSze Then
'save image as RLE4 format - output size calculated as smaller than 1bite version
SaveAs4BitRLEBMP handle, ToFile
Else
SaveBMP1 handle, ToFile 'SUB reapired. Very very much... now he autodetect correctly mask colors and works as expected finally...
'save as uncompressed 1 bit format
End If
Case 3 To 16
If EfficiencyRLE(handle, 4, RleSze) Then
'save as compressed 4 bit BMP
SaveAs4BitRLEBMP handle, ToFile
Else
'save as ucompressed 4 bit BMP
SaveAs4BitBMP handle, ToFile
End If
Case 17 To 256
If EfficiencyRLE(handle, 8, RleSze) Then
'save as compressed 8 bit BMP
SaveAs8BitRLEBMP handle, ToFile
Else
'save as uncompressed 8 bit BMP
Save8BitBMP handle, ToFile
End If
End Select
End Select
End Sub
Function EfficiencyRLE (handle As Long, mode As _Byte, RLESze As Long) 'mode: 4 bit (16 colors) or 8 bit (256 colors)
Dim m As _MEM
m = _MemImage(handle)
Dim a As Long
Dim compSize As Long ' Vcompressed size in bytes
Dim runLength As Long ' how much is one value repeated (count)
Dim currentValue As _Unsigned _Byte
Dim nextValue As _Unsigned _Byte
'if image handle is valid
If m.SIZE = 0 Then
EfficiencyRLE = 0
Exit Function
End If
compSize = 0
runLength = 1
currentValue = _MemGet(m, m.OFFSET, _Unsigned _Byte)
For a = 1 To m.SIZE - 1
nextValue = _MemGet(m, m.OFFSET + a, _Unsigned _Byte)
If nextValue = currentValue Then
runLength = runLength + 1
' if is 255, reset back to 0 and save lenght
If runLength = 255 Then
compSize = compSize + 2 ' 1 byte for lenght, 1 byte for value (index value in image)
runLength = 0
'if the next pixel is still the same, the cycle continues and a new record will be created.
End If
Else
' If the value changes, we write the current run (can be shorter than 255)
If runLength > 0 Then
compSize = compSize + 2 ' Run record: length and value
End If
currentValue = nextValue
runLength = 1
End If
Next a
' We save the last run, if there is any left.
If runLength > 0 Then
compSize = compSize + 2
End If
' The function returns the total size of the compressed data.
If mode = 8 Then N = 1 Else N = .5
If N * compSize < N * m.SIZE Then EfficiencyRLE = 1 Else EfficiencyRLE = 0 'if compressed size is slower, use it
RLESze& = compSize
End Function
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, index
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)
a = a + 1
If d(index) = 0 Then
ClrScn = ClrScn + 1
d(index) = 1
End If
Loop
ClrsCnt = ClrScn
End If
End Function
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
Dim byte1 As _Unsigned _Byte, byte2 As _Unsigned _Byte, pixel16 As _Unsigned Integer
Dim red5 As Long, green5 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 _Offset
' 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
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:
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)
r8 = (red5 * 255) \ 31
g8 = (green5 * 255) \ 31
b8 = (blue5 * 255) \ 31
pixel32 = _RGB32(r8, g8, b8)
offsetTarget = newMem.OFFSET + (targetRow * newRowStep) + (x * 4)
_MemPut newMem, offsetTarget, pixel32 As _UNSIGNED LONG
Next x
Next y
Load16BitBMP555& = newImg
End Function
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
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
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
width = Abs(width)
height = Abs(height)
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
Sub SaveAs8BitRLEBMP (sourceImg&, outputFile$)
' Rozmýry obrßzku Determine image dimensions
Dim W As Long, H As Long
W = _Width(sourceImg&)
H = _Height(sourceImg&)
Dim totalPixels As Long
totalPixels = W * H
' NaŔteme vÜechna 8bitovß data do °etýzce (top-down po°adÝ) Load all 8-bit data into a string (top-down order)
Dim raw As String
raw$ = Space$(totalPixels)
Dim m As _MEM
m = _MemImage(sourceImg&)
_MemGet m, m.OFFSET, raw$
_MemFree m
' P°ipravÝme vřslednř RLE8 °etýzec Prepare the resulting RLE8 string
Dim rleData As String
rleData = ""
' Pro ka×dř °ßdek v po°adÝ bottom-up:
' ěßdek y v BMP => reßlnř °ßdek = (H-1) - y v raw$
Dim y As Long
For y = 0 To H - 1
Dim realRow As Long
realRow = (H - 1) - y
Dim offset As Long
offset = realRow * W
Dim lineData As String
lineData$ = Mid$(raw$, offset + 1, W)
' Zakˇdujeme jeden °ßdek pomocÝ RLE8EncodeLine$ Encode one line using RLE8EncodeLine$
rleData = rleData + RLE8EncodeLine$(lineData$)
' Na konec °ßdku p°idßme "0,0" (End Of Line) Append "0,0" (End Of Line) at the end of the line
rleData = rleData + Chr$(0) + Chr$(0)
Next y
' Po poslednÝm °ßdku je jeÜtý "0,1" (End Of Bitmap) After the last line, add "0,1" (End Of Bitmap)
rleData = rleData + Chr$(0) + Chr$(1)
' -------------------------------------------------------
' Vytvo°Ýme BMP hlaviŔku (FileHeader + InfoHeader). Create the BMP header (FileHeader + InfoHeader).
Type BMP8BitHeader
signature As String * 2 ' "BM"
fileSize As Long
reserved1 As Integer
reserved2 As Integer
dataOffset As Long
infoHeaderSize As Long
width As Long
height As Long
planes As Integer
bitsPerPixel As Integer
compression As Long ' BI_RLE8 = 1
imageSize As Long
xPelsPerMeter As Long
yPelsPerMeter As Long
colorsUsed As Long
importantColors As Long
End Type
Dim bmp As BMP8BitHeader
bmp.signature = "BM"
bmp.reserved1 = 0
bmp.reserved2 = 0
bmp.infoHeaderSize = 40
bmp.width = W
bmp.height = H
bmp.planes = 1
bmp.bitsPerPixel = 8
bmp.compression = 1 ' BI_RLE8 BI_RLE8
bmp.imageSize = Len(rleData)
bmp.xPelsPerMeter = 0
bmp.yPelsPerMeter = 0
bmp.colorsUsed = 256
bmp.importantColors = 256
Dim headerSize As Long
headerSize = 14 + 40 + (256 * 4) ' FileHeader + InfoHeader + palette
bmp.dataOffset = headerSize
bmp.fileSize = headerSize + bmp.imageSize
' Paleta: 256 polo×ek Palette: 256 entries
Dim ColorTable(0 To 255) As _Unsigned Long
Dim iColor As Long
For iColor = 0 To 255
ColorTable(iColor) = _PaletteColor(iColor, sourceImg&)
Next iColor
' Zßpis vřslednÚho souboru Write the output file
If _FileExists(outputFile$) Then Kill outputFile$
Open outputFile$ For Binary As #1
' FileHeader (14 bajt¨) FileHeader (14 bytes)
Put #1, , bmp.signature
Put #1, , bmp.fileSize
Put #1, , bmp.reserved1
Put #1, , bmp.reserved2
Put #1, , bmp.dataOffset
' InfoHeader (40 bajt¨) InfoHeader (40 bytes)
Put #1, , bmp.infoHeaderSize
Put #1, , bmp.width
Put #1, , bmp.height
Put #1, , bmp.planes
Put #1, , bmp.bitsPerPixel
Put #1, , bmp.compression
Put #1, , bmp.imageSize
Put #1, , bmp.xPelsPerMeter
Put #1, , bmp.yPelsPerMeter
Put #1, , bmp.colorsUsed
Put #1, , bmp.importantColors
' Paleta (256 * 4 bajt¨) Palette (256 * 4 bytes)
For iColor = 0 To 255
Put #1, , ColorTable(iColor)
Next iColor
' Zßpis RLE8 dat Write RLE8 data
Put #1, , rleData
Close #1
End Sub
'-------------------------------------------------------------
' RLE8EncodeLine$ (zakˇduje jeden °ßdek do RLE8) Encodes one line using RLE8
'
' Jednoduchř, klasickř postup:
' - ZkusÝme spoŔÝtat run (>=2?), pokud ano => [count][value]. Try to count a run (>=2?), if so => [count][value].
' - Jinak vytvo°Ýme "absolutnÝ" blok, do nýj sbÝrßme pixely,
' dokud nenarazÝme na run >=2 nebo 255 Ŕi konec °ßdku. Otherwise, form an "absolute" block, gathering pixels until encountering a run >=2, 255, or end of line.
' - AbsolutnÝ blok => 0, [count], data, + pad byte (pokud count je lichř). Absolute block => 0, [count], data, plus a pad byte (if count is odd).
'----------------------------------------------------------------------------- because absolute blocks working bad, all blocks in program are cset as RLE (condition is not If RLE >=2 but
Function RLE8EncodeLine$ (lineData$) ' but If RLE > = 1
Dim result As String
result = ""
Dim length As Long
length = Len(lineData$)
Dim i As Long
i = 1
j = 1
Do While i <= length
' ZjistÝme run Determine the run
Dim c As _Unsigned _Byte
c = Asc(Mid$(lineData$, i, 1))
Dim runCount As Long
runCount = 1
' Kolik se opakuje? How many times does it repeat?
While (i + runCount <= length) And (runCount < 255)
If Asc(Mid$(lineData$, i + runCount, 1)) = c Then
runCount = runCount + 1
Else
Exit While
End If
Wend
If runCount >= 1 Then ' tu mß břt 2, ale s1 to funguje should be 2, but works with 1 - specification is 2. Then if RunLenght is 1, program create absolut block. BUT this
' Bý×ový zakˇdovanř Encoded as a run cause bug in image (i do not know why) - image from this point is black (if 2 is used). Something in ELSE condition is wrong, but i
result = result + Chr$(runCount) + Chr$(c) ' don't know what...
i = i + runCount
Else
' AbsolutnÝ re×im Absolute mode - in this ELSE condition is somewhere bug... see, in this version program never come here (because this part
Dim absBlock As String ' is wrong. Rwrite IF runCount => 2 above and then run it and see. Test output images also in photo viewer, so you can see, that
absBlock = "" ' this bug is here, not in Load8BitRLEBMP& function...
Dim absCount As Long
absCount = 0
j = 1
Do While (i <= length) And (absCount < 255)
' P°idßme 1 pixel Add one pixel
i = i + 1
absBlock = absBlock + Mid$(lineData$, i, 1)
absCount = absCount + 1
' Dßle zkontrolujeme, jestli za i nenÝ run >=2 Then check if a run >=2 starts at i
If i <= length Then
Dim c2 As _Unsigned _Byte
c2 = Asc(Mid$(lineData$, i, 1))
Dim r2 As Long
r2 = 1
While (i + r2 <= length) And (r2 < 255)
If Asc(Mid$(lineData$, i + r2, 1)) = c2 Then
r2 = r2 + 1
absBlock = absBlock + Chr$(c2)
Else
Exit While
End If
Wend
If r2 >= 2 Then
Exit Do ' naÜli jsme run, ukonŔÝme absolutnÝ blok Found a run, exit absolute block (if we found two or more then same pixels (colors) return back to RLE)
End If
End If
j = j + 1
Loop
' Ulo×Ýme ABS blok => 0, [absCount], data Store the absolute block => 0, [absCount], data 0 is signal for encoder, that here start absolute block, then is count (how much pixels, max is 255), then bytes with colors.
result = result + Chr$(0) + Chr$(absCount) + absBlock
' ZarovnßnÝ na sudř poŔet bajt¨ Pad to even number of bytes
If (absCount Mod 2) <> 0 Then
result = result + Chr$(0)
End If
End If
Loop
RLE8EncodeLine$ = result
End Function
Function Load8BitRLEBMP& (fileName$)
' Otev°e BMP soubor, naŔte hlaviŔku, paletu a RLE8 data
' a dekˇduje je do novÚho 8bitovÚho obrßzku v QB64PE. Opens a BMP file, loads the header, palette, and RLE8 data,
' Returns handle novÚho obrßzku, nebo 0 p°i chybý. and decodes them into a new 8-bit image in QB64PE.
Dim fileNum As Integer
fileNum = FreeFile
Open fileName$ For Binary As #fileNum
If LOF(fileNum) < 54 Then
Print "Soubor je p°ÝliÜ malř, aby to byl platnř BMP." ' Soubor je p°ÝliÜ malř pro platnř BMP File is too small to be a valid BMP.
Close #fileNum
Load8BitRLEBMP& = 0
Exit Function
End If
' [1] NaŔtenÝ 14bytovÚ BMP hlaviŔky Load the 14-byte BMP header
Dim signature As String * 2
Dim fileSize As Long, reserved1 As Integer, reserved2 As Integer, dataOffset As Long
Get #fileNum, , signature
If signature <> "BM" Then
Print "Nejednß se o platnř BMP soubor (chybÝ podpis 'BM')!" ' NenÝ platnř BMP soubor (chybÝ 'BM') Not a valid BMP file (missing 'BM' signature)!
Close #fileNum
Load8BitRLEBMP& = 0
Exit Function
End If
Get #fileNum, , fileSize
Get #fileNum, , reserved1
Get #fileNum, , reserved2
Get #fileNum, , dataOffset
' [2] NaŔtenÝ BITMAPINFOHEADER (40 bajt¨) Load the BITMAPINFOHEADER (40 bytes)
Dim infoHeaderSize As Long, width As Long, height As Long
Dim planes As Integer, bitsPerPixel As Integer, compression As Long
Dim imageSize As Long, xPelsPerMeter As Long, yPelsPerMeter As Long
Dim colorsUsed As Long, importantColors As Long
Get #fileNum, , infoHeaderSize
Get #fileNum, , width
Get #fileNum, , height
Get #fileNum, , planes
Get #fileNum, , bitsPerPixel
Get #fileNum, , compression
Get #fileNum, , imageSize
Get #fileNum, , xPelsPerMeter
Get #fileNum, , yPelsPerMeter
Get #fileNum, , colorsUsed
Get #fileNum, , importantColors
If bitsPerPixel <> 8 Then
Print "Nejednß se o 8bit BMP!" ' Obrßzek nenÝ 8bitovř Image is not an 8-bit BMP!
Close #fileNum
Load8BitRLEBMP& = 0
Exit Function
End If
If compression <> 1 Then
Print "BMP nenÝ komprimovßn metodou RLE8 (BI_RLE8)!" ' BMP nenÝ komprimovßn RLE8 BMP is not compressed with RLE8 (BI_RLE8)!
Close #fileNum
Load8BitRLEBMP& = 0
Exit Function
End If
' Pokud v hlaviŔce nenÝ uvedeno colorsUsed, nastavÝme 256 If colorsUsed is not specified in the header, set to 256
If colorsUsed = 0 Or colorsUsed > 256 Then
colorsUsed = 256
End If
' [3] NaŔtenÝ palety (a× 256 zßznam¨) Load the palette (up to 256 entries)
Dim pal(0 To 255) As _Unsigned Long
Dim i As Long
For i = 0 To colorsUsed - 1
Dim blue As _Unsigned _Byte, green As _Unsigned _Byte, red As _Unsigned _Byte, reservedPal As _Unsigned _Byte
Get #fileNum, , blue
Get #fileNum, , green
Get #fileNum, , red
Get #fileNum, , reservedPal
' SestavÝme do &H00RRGGBB Assemble into &H00RRGGBB format
pal(i) = _RGBA32(red, green, blue, reservedPal)
Next i
' ZbylÚ barvy, pokud colorsUsed < 256, lze doplnit Ŕernou Remaining colors, if colorsUsed < 256, can be filled with black
For i = colorsUsed To 255
' pal(i) = &H0
Next i
' [4] NastavenÝ ukazatele na data Seek to the data offset
Seek #fileNum, dataOffset + 1
If imageSize = 0 Then
' Pokud je imageSize=0, pou×ijeme zbytek souboru If imageSize=0, use the rest of the file
imageSize = fileSize - dataOffset
End If
' [5] NaŔtenÝ RLE8 dat Load the RLE8 data
If imageSize < 2 Then
Print "BMP: imageSize je p°ÝliÜ malř, neplatnß data." ' imageSize je p°ÝliÜ malř imageSize is too small, invalid data.
Close #fileNum
Load8BitRLEBMP& = 0
Exit Function
End If
Dim rleData As String
rleData = Space$(imageSize)
Get #fileNum, , rleData
Close #fileNum
' [6] Vytvo°enÝ novÚho 8bitovÚho obrßzku v QB64PE Create a new 8-bit image in QB64PE
Dim img As Long
img = _NewImage(width, height, 256)
' NastavenÝ palety Set the palette
For i = 0 To 255
_PaletteColor i, pal(i), img
Next i
' ZÝskßnÝ pamýŁovÚho bloku obrßzku Obtain the memory block of the image
Dim memImg As _MEM
memImg = _MemImage(img)
' SpoŔÝtßme rowPitch = celkovß velikost / poŔet °ßdk¨
' (V QB64PE 8bit je ulo×en lineßrný bez mezer) Calculate rowPitch = total size / number of rows
Dim rowPitch As Long
rowPitch = memImg.SIZE \ height ' Pro 8bit by to mýlo staŔit For 8-bit, this should suffice
' [7] DekˇdovßnÝ RLE8 dat Decode the RLE8 data
Dim dataLen As Long
dataLen = Len(rleData)
Dim curRow As Long
curRow = 0
Dim curCol As Long
curCol = 0
Dim posByte As Long
posByte = 1
Do While posByte <= dataLen
' Pokud jsme na konci, ukonŔÝme If at end, exit loop
If posByte > dataLen Then Exit Do
Dim countByte As _Unsigned _Byte
countByte = Asc(Mid$(rleData, posByte, 1))
posByte = posByte + 1
' Pokud jsme na konci, ukonŔÝme Check end again
If posByte > dataLen Then Exit Do
Dim dataByte As _Unsigned _Byte
dataByte = Asc(Mid$(rleData, posByte, 1))
posByte = posByte + 1
If countByte = 0 Then
' --- SpecißlnÝ p°Ýkazy --- --- Special commands ---
Select Case dataByte
Case 0
' Konec °ßdku End of line
curRow = curRow + 1
curCol = 0
Case 1
' Konec bitmapy End of bitmap
Exit Do
Case 2
' Delta posun Delta move
If posByte + 1 <= dataLen Then
Dim dx As _Unsigned _Byte, dy As _Unsigned _Byte
dx = Asc(Mid$(rleData, posByte, 1))
dy = Asc(Mid$(rleData, posByte + 1, 1))
posByte = posByte + 2
curCol = curCol + dx
curRow = curRow + dy
Else
Exit Do
End If
Case Else
' AbsolutnÝ blok o dÚlce dataByte Absolute block with length dataByte
Dim absCount As Long
absCount = dataByte
If absCount = 0 Then Exit Do
If posByte + absCount - 1 > dataLen Then Exit Do
Dim absData As String
absData = Mid$(rleData, posByte, absCount)
posByte = posByte + absCount
' ZkopÝrujeme do obrßzku Copy into the image
Dim k As Long
For k = 1 To absCount
Dim pixIndex As _Unsigned _Byte
pixIndex = Asc(Mid$(absData, k, 1))
' Bottom-up => fyzickř °ßdek = (height - 1 - curRow) Bottom-up: physical row = (height - 1 - curRow)
If curRow < height Then
If curCol < width Then
Dim memOffset As _Offset
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
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)
' already located in Save16bitBMP555
Dim fh As BMPFileHeader
fh.bfType = "BM"
fh.bfSize = fileSize
fh.bfRes1 = 0
fh.bfRes2 = 0
fh.bfOffBits = headerSize
' --- BMP InfoHeader (40 bytes)
'' already located in Save16bitBMP555
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$ ' Lteme °ß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
Sub SaveBMP1 (imageRef As Long, fileName As String)
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)
ColorA1 As String * 4 ' První barva (obvykle popředí) First color (usually foreground)
ColorB1 As String * 4 ' První barva (obvykle popředí) First color (usually foreground)
End Type
'Autodetect Foreground color (FgC and background Color (BgC) - this version expected max 2 colors in input image
Dim C As _MEM
Dim As _Unsigned Long FgC, BgC, Clr1, Clr2
Dim As _Unsigned _Byte indexC, IndexD
Dim JJJ As Long
C = _MemImage(imageRef)
indexC = _MemGet(C, C.OFFSET, _Unsigned _Byte)
IndexD = indexC
Do Until IndexD <> indexC Or JJJ > C.SIZE
IndexD = _MemGet(C, C.OFFSET + JJJ, _Unsigned _Byte)
JJJ = JJJ + 1
' If indexC <> IndexD Then Exit Do
Loop
_MemFree C
Clr1 = _PaletteColor(indexC, imageRef)
Clr2 = _PaletteColor(IndexD, imageRef)
FgC$ = Chr$(_Blue32(Clr1)) + Chr$(_Green32(Clr1)) + Chr$(_Red32(Clr1)) + Chr$(0)
BgC$ = Chr$(_Blue32(Clr2)) + Chr$(_Green32(Clr2)) + Chr$(_Red32(Clr2)) + Chr$(0)
'continue
' 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.ColorA1 = FgC$ ' Foreground barva Foreground color
BMP1.ColorB1 = 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) \ 256 'corrected...
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 resourc
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 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)
Type BMPINFOHEADER1
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
Dim header As BMPHEADER
Dim info As BMPINFOHEADER1
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
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
' ===== 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
Type Pixel
r As _Unsigned _Byte
g As _Unsigned _Byte
b As _Unsigned _Byte
a As _Unsigned _Byte
End Type
Function clampVal& (theValue As Long, minValue As Long, maxValue As Long)
If theValue < minValue Then theValue = minValue
If theValue > maxValue Then theValue = maxValue
clampVal = theValue
End Function
Sub boxBlur3x3 (Handle As Long) 'smooth image (rewrite original values in 32 bit output handle)
w = _Width(Handle)
h = _Height(Handle)
Dim expectedSize As Long
Dim C As Long
Dim m As _MEM
m = _MemImage(Handle)
'working in arrays for faster speed
ReDim inPixels(0 To h - 1, 0 To w - 1) As Pixel
ReDim outPixels(0 To h - 1, 0 To w - 1) As Pixel
'load pixels do inPixels array
For y = 0 To h - 1
For x = 0 To w - 1
C = 4 * ((w * y) + x)
inPixels(y, x).r = _MemGet(m, m.OFFSET + C, _Unsigned _Byte)
inPixels(y, x).g = _MemGet(m, m.OFFSET + C + 1, _Unsigned _Byte)
inPixels(y, x).b = _MemGet(m, m.OFFSET + C + 2, _Unsigned _Byte)
Next x, y
' Proceed box blur in inPixels, save it to outPixels
Dim sumR As Long, sumG As Long, sumB As Long
Dim xx As Long, yy As Long
Dim x As Long, y As Long
Dim dx As Long, dy As Long
For y = 0 To h - 1
For x = 0 To w - 1
sumR = 0: sumG = 0: sumB = 0
' 3x3
For dy = -1 To 1
For dx = -1 To 1
yy = clampVal(y + dy, 0, h - 1)
xx = clampVal(x + dx, 0, w - 1)
sumR = sumR + inPixels(yy, xx).r
sumG = sumG + inPixels(yy, xx).g
sumB = sumB + inPixels(yy, xx).b
Next dx
Next dy
outPixels(y, x).r = sumR \ 9
outPixels(y, x).g = sumG \ 9
outPixels(y, x).b = sumB \ 9
'alpha is not used
outPixels(y, x).a = inPixels(y, x).a
Next x
Next y
'copy array outPixels back to image handle
Dim n As _MEM
n = _Mem(outPixels())
Dim totalSize As Long
totalSize = m.SIZE
For y = 0 To h - 1
For x = 0 To w - 1
C = 4 * ((w * y) + x)
_MemPut m, m.OFFSET + C, outPixels(y, x).r As _UNSIGNED _BYTE
_MemPut m, m.OFFSET + C + 1, outPixels(y, x).g As _UNSIGNED _BYTE
_MemPut m, m.OFFSET + C + 2, outPixels(y, x).b As _UNSIGNED _BYTE
Next x, y
Erase inPixels 'clear RAM
Erase outPixels
_MemFree n
_MemFree m
End Sub
The attached image contains only 9 colors. It shows the filter's work nicely. (if you save it in the program)