02-16-2025, 01:46 PM
This program will make you feel nostalgic. PCX is an old image storage format. It uses RLE compression, which is not very efficient, especially for 24-bit images. Another limitation is that only black and white are allowed in 1-bit (two-color) PCX files. I assume this because no matter what I put in the palette, I always got black and white, or white and black.
Below is a demo that takes images (drawn with the LINE command) that have the correct number of colors and saves them to disk in PCX format. _LoadImage supports PCX, _SaveImage does not support PCX (that's why I went to it), so _LoadImage loads this image from disk and displays it immediately.
The program stores 1-bit PCX in 2 colors, 2-bit PCX in 4 colors, 4-bit PCX in 16 colors, 8-bit PCX in 256 colors, and 24-bit PCX - there are millions of colors.
There is no check if you are inserting the correct image format. To find out the number of colors, use the function ClrsCnt(handle). It is included as next program.
Below is a demo that takes images (drawn with the LINE command) that have the correct number of colors and saves them to disk in PCX format. _LoadImage supports PCX, _SaveImage does not support PCX (that's why I went to it), so _LoadImage loads this image from disk and displays it immediately.
The program stores 1-bit PCX in 2 colors, 2-bit PCX in 4 colors, 4-bit PCX in 16 colors, 8-bit PCX in 256 colors, and 24-bit PCX - there are millions of colors.
There is no check if you are inserting the correct image format. To find out the number of colors, use the function ClrsCnt(handle). It is included as next program.
Code: (Select All)
' --- Definice typu pro PCX hlavičku / Definition of the PCX header type ---
Type PCXHeader ' This TYPE is here commented for 1 bit PCX!
Manufacturer As _Unsigned _Byte ' PCX identifikátor (0x0A) / PCX identifier (0x0A)
Version As _Unsigned _Byte ' Verze (např. 5 = PC Paintbrush 3.0) Version (e.g., 5 = PC Paintbrush 3.0)
Encoding As _Unsigned _Byte ' 1 = RLE komprese 1 = RLE compression
BitsPerPixel As _Unsigned _Byte ' x - bit (x - bitový obrázek) x - bit per pixel (monochrome image or more)
XMin As _Unsigned Integer ' Levý horní X (0) Top-left X coordinate (0)
YMin As _Unsigned Integer ' Levý horní Y (0) Top-left Y coordinate (0)
XMax As _Unsigned Integer ' Pravý dolní X (šířka - 1) Bottom-right X coordinate (width - 1)
YMax As _Unsigned Integer ' Pravý dolní Y (výška - 1) Bottom-right Y coordinate (height - 1)
HDPI As _Unsigned Integer ' Horizontální DPI (např. 300) Horizontal DPI (e.g., 300)
VDPI As _Unsigned Integer ' Vertikální DPI (např. 300) Vertical DPI (e.g., 300)
ColorMap As String * 48 ' Paleta – u 1bit PCX využijeme první 6 bajtů: Palette – for 1-bit PCX we use the first 6 bytes:
' Index 0: černá (0,0,0), Index 1: bílá (255,255,255) Index 0: black (0,0,0), Index 1: white (255,255,255)
Reserved As _Unsigned _Byte ' Rezervováno (0) Reserved (0)
Planes As _Unsigned _Byte ' Počet rovin (1) Number of color planes (1)
BytesPerLine As _Unsigned Integer ' Počet bajtů na řádek (zarovnaný na sudé číslo Bytes per line (aligned to an even number)
PaletteInfo As _Unsigned Integer ' 1 = obrázek je monochromatický 1 = image is monochrome (Each storage program sets its own values)
HScreenSize As _Unsigned Integer ' Horizontální velikost obrazovky (0) Horizontal screen size (0)
VScreenSize As _Unsigned Integer ' Vertikální velikost obrazovky (0) Vertical screen size (0)
Filler As String * 54 ' Vyplňovací bajty (nulové) Filler bytes (zeros)
End Type
Type RGB
As _Unsigned _Byte r, g, b, original ' r, g, b složky a původní index r, g, b components and original palette index
End Type
ReDim Shared UsedColors(0) As RGB ' Sdílené pole pro použité barvy Shared array for used colors (for mask)
Screen _NewImage(1024, 768, 32)
Colors2image = _NewImage(640, 480, 256) ' Obrázek s 256 barvami 256-color image - contains 2 colors, but PCX not accepts it. PCX in 1 bit mode always use Black and White.
_Dest Colors2image
For f = 50 To 240 Step 10
Line (0 + f, 0 + f)-(640 - f, 480 - f), 6 * (f And 2), BF
' Vykreslíme diagonální gradient Draw a diagonal gradient
Next
Colors4image = _NewImage(640, 480, 256) ' Obrázek pro 4 barvy (2-bit) 4-color image (2-bit)
_Dest Colors4image
For f = 50 To 240 Step 10
Line (0 + f, 0 + f)-(640 - f, 480 - f), 15 * (f And 7), BF
Next
Colors16image = _NewImage(640, 480, 256) ' Obrázek pro 16 barev (4-bit) 16-color image (4-bit)
_Dest Colors16image
For f = 50 To 240 Step 5
Line (0 + f, 0 + f)-(640 - f, 480 - f), f And 15, BF
Next
Colors256image = _NewImage(640, 480, 256) ' Obrázek pro 256 barev (8-bit) 256-color image (8-bit)
_Dest Colors256image
For f = 0 To 255
Line (0 + f, 0 + f)-(640 - f, 480 - f), f And 255, BF
Next
Color24bitImage = _NewImage(640, 480, 32) ' Obrázek pro 24bit (milióny barev) 24-bit image (16,777,216 colors)
_Dest Color24bitImage
For f = 0 To 255 Step .5
Line (0 + f, 0 + f)-(640 - f, 480 - f), _RGB32((f And 127), (255 - (f And 64)), (f Xor 15)), BF
Next
_Dest 0
' --- Hlavní demo část / Main demo section ---
Print "PCX Save Image Demo"
Print
Print "Program generate and save 5 PCX files and then load and show it."
Print "Step 1/5: Save 1bit (2 colors) PCX image and then show it! PCX format in 1 bit mode support just BLACK or WHITE color."
SavePCX1Clr Colors2image, "Two_Colors.pcx"
Print "Image saved."
image = _LoadImage("Two_Colors.pcx", 256)
_PutImage (200, 200), image
Sleep
Cls
Print "PCX Save Image Demo"
Print
Print "Program generate and save 5 PCX files and then load and show it."
Print "Step 2/5: Save 2bit (4 colors) PCX image and then show it!"
SavePCX4Clr Colors4image, "Four_Colors.pcx"
Print "Image saved."
image = _LoadImage("Four_Colors.pcx", 256)
_PutImage (200, 200), image
_FreeImage image
Sleep
Cls
Print "PCX Save Image Demo"
Print
Print "Program generate and save 5 PCX files and then load and show it."
Print "Step 3/5: Save 4bit (16 colors) PCX image and then show it! PCX here standardly expect EGA color palette. Some dekodéry use EGA palette, not colors in file palette, but _LoadImage accepts file palette!"
SavePCX16Clr Colors16image, "16_Colors.pcx"
Print "Image saved."
image = _LoadImage("16_Colors.pcx", 256)
_PutImage (200, 200), image
_FreeImage image
Sleep
Cls
Print "PCX Save Image Demo"
Print
Print "Program generate and save 5 PCX files and then load and show it."
Print "Step 4/5: Save 8bit (256 colors) PCX image and then show it!"
SavePCX256clr Colors256image, "256_Colors.pcx"
Print "Image saved."
image = _LoadImage("256_Colors.pcx", 256)
_PutImage (200, 200), image
_FreeImage image
Sleep
Cls
Print "PCX Save Image Demo"
Print
Print "Program generate and save 5 PCX files and then load and show it."
Print "Step 5/5: Save 24bit (16 777 216 colors) PCX image and then show it!"
SavePCX24 Color24bitImage, "24bit_Colors.pcx"
Print "Image saved."
image = _LoadImage("24bit_Colors.pcx", 32)
_PutImage (200, 200), image
_FreeImage image
Sleep
Cls
Print "All files are on on your harddrive: Two_Colors.pcx, Four_Colors.pcx, 16_Colors.pcx, 256_Colors.pcx and 24bit_Colors.pcx"
Print "I assume you won't be saving anything big with this, mainly because of the inefficient compression for 24 bit images."
Print "The program is only for demonstration purposes. _SaveImage doesn't support saving in PCX, now you have that option."
End
' -------------------------------------------------------------------------------------------
' Function GetUsedColors – naplní pole UsedColors barvami z indexovaného obrázku.
' Function GetUsedColors – fills the UsedColors array with colors from the indexed image.
' -------------------------------------------------------------------------------------------
Function GetUsedColors (image As Long)
If _PixelSize(image) > 1 Then Beep: Beep: Beep: GetUsedColors = -1: Stop
ReDim UsedColors(-1) As RGB
' Cílem je naplnit UsedColors strukturou s RGB hodnotami _RGB32 z obrázku,
' aby byly barvy seřazeny dle jejich výskytu.
' The goal is to fill UsedColors with the RGB values (via _RGB32) from the image,
' so that the colors are stored in the order they are encountered.
Dim ColorWrited(255) As _Byte
Dim Clr As _Unsigned _Byte
S = _Source
_Source image
For y = 0 To _Height(image) - 1
For x = 0 To _Width(image) - 1
Clr = Point(x, y)
If ColorWrited(Clr) = 0 Then
ColorWrited(Clr) = 1
U = UBound(UsedColors)
U = U + 1
ReDim _Preserve UsedColors(U) As RGB
UsedColors(U).r = _Red32(_PaletteColor(Clr, image))
UsedColors(U).g = _Green32(_PaletteColor(Clr, image))
UsedColors(U).b = _Blue32(_PaletteColor(Clr, image))
UsedColors(U).original = Clr
End If
Next x
Next y
_Source S
GetUsedColors = U + 1
End Function
' -------------------------------------------------------------------------------------------
' SUB SavePCX1Clr – uloží obrázek jako 1bit (2 barvy) PCX soubor.
' SUB SavePCX1Clr – saves the image as a 1-bit (2-color) PCX file.
' Vstupní parametry: imagePtr (ukazatel na obrázek), fileName (název souboru)
' Input parameters: imagePtr (image pointer), fileName (output file name)
' -------------------------------------------------------------------------------------------
Sub SavePCX1Clr (imagePtr As Long, fileName As String)
Dim imgWidth As Integer, imgHeight As Integer
imgWidth = _Width(imagePtr)
imgHeight = _Height(imagePtr)
' Výpočet počtu bajtů na řádek: (imgWidth+7) \ 8, následně zarovnáme na sudé číslo
' Calculate bytes per line for 1-bit image and align to even number
Dim bytesPerLine As Integer
bytesPerLine = (imgWidth + 7) \ 8
If (bytesPerLine Mod 2) <> 0 Then bytesPerLine = bytesPerLine + 1
status = GetUsedColors(imagePtr)
myMask$ = TransformMask 'you can test it. Mask contains valid colors (not black and white) but - image is black and white.
' --- Příprava PCX hlavičky / Preparing the PCX header ---
Dim hdr As PCXHeader
hdr.Manufacturer = &H0A
hdr.Version = 5
hdr.Encoding = 1
hdr.BitsPerPixel = 1
hdr.XMin = 0
hdr.YMin = 0
hdr.XMax = imgWidth - 1
hdr.YMax = imgHeight - 1
hdr.HDPI = 300
hdr.VDPI = 300
' U 1bit PCX využijeme 2 barvy: černá a bílá / For 1-bit PCX we use 2 colors: black and white.
'hdr.ColorMap = Chr$(0) + Chr$(0) + Chr$(0) + Chr$(255) + Chr$(255) + Chr$(255) + String$(42, Chr$(0))
hdr.ColorMap = myMask$ + String$(48 - Len(myMask$), Chr$(0))
hdr.Reserved = 0
hdr.Planes = 1
hdr.BytesPerLine = bytesPerLine
hdr.PaletteInfo = 1
hdr.HScreenSize = 0
hdr.VScreenSize = 0
hdr.Filler = String$(54, Chr$(0))
' --- Otevření souboru pro zápis / Open file for binary writing ---
Dim fileNum As Integer
fileNum = FreeFile
Open fileName For Binary As #fileNum
' Zápis 128 bajtů hlavičky do souboru / Write 128-byte header to file
Put #fileNum, , hdr
' --- Zpracování a zápis obrazových dat řádek po řádku / Process and write image data line by line ---
Dim y As Integer, x As Integer
Dim rawLine As String, encodedLine As String
Dim currentByte As Integer, count As Integer
Dim i As Integer
Dim pixelVal As Integer
S = _Source
For y = 0 To imgHeight - 1
' Inicializace řádku s délkou bytesPerLine (všechno nastaveno na 0)
' Initialize a line filled with zeros
rawLine = String$(bytesPerLine, Chr$(0))
For x = 0 To imgWidth - 1
Dim byteIndex As Integer, bitIndex As Integer
byteIndex = x \ 8
bitIndex = 7 - (x Mod 8)
currentByte = Asc(Mid$(rawLine, byteIndex + 1, 1))
' Získání hodnoty pixelu z obrázku pomocí _POINT (0 = černá, nenulová = bílá)
' Get pixel value from image; assume nonzero means white pixel.
_Source imagePtr
pixelVal = PCXPointer(Point(x, y))
If pixelVal <> 0 Then
currentByte = currentByte Or (2 ^ bitIndex)
End If
Mid$(rawLine, byteIndex + 1, 1) = Chr$(currentByte)
Next x
' --- RLE kódování řádku podle PCX specifikace / RLE encoding of the line as per PCX spec ---
encodedLine = ""
i = 1
Do While i <= Len(rawLine)
currentByte = Asc(Mid$(rawLine, i, 1))
count = 1
Do While (i + count <= Len(rawLine)) And (count < 63)
If Asc(Mid$(rawLine, i + count, 1)) = currentByte Then
count = count + 1
Else
Exit Do
End If
Loop
If (count = 1) And (currentByte < 192) Then
encodedLine = encodedLine + Chr$(currentByte)
Else
encodedLine = encodedLine + Chr$(192 + count) + Chr$(currentByte)
End If
i = i + count
Loop
' Zápis RLE kódovaného řádku do souboru / Write the RLE encoded line to file
Put #fileNum, , encodedLine
Next y
_Source S
Close #fileNum
End Sub
' -------------------------------------------------------------------------------------------
' SUB SavePCX4Clr – uloží obrázek jako 4barevný (2bitový) PCX soubor.
' SUB SavePCX4Clr – saves the image as a 4-color (2-bit) PCX file.
' Vstupní parametry: image (ukazatel na obrázek), fileName (název souboru)
' Input parameters: image (image pointer), fileName (output file name)
' -------------------------------------------------------------------------------------------
Sub SavePCX4Clr (image As Long, fileName As String)
' Získání rozměrů obrázku Get image dimensions
Dim width As Integer, height As Integer
width = _Width(image)
height = _Height(image)
' Výpočet bajtů na rovinu: (width+7)\8 a zarovnání na sudé číslo Calculate bytes per line (for 1-bit plane) and align to even number
Dim bytesPerLine As Integer
bytesPerLine = (width + 7) \ 8
If (bytesPerLine Mod 2) <> 0 Then bytesPerLine = bytesPerLine + 1
status = GetUsedColors(image)
myMask$ = TransformMask
Dim colorMap4 As String
colorMap4 = myMask$ + String$(48 - Len(myMask$), Chr$(0))
' ---------------------------------------------------
' Sestavení PCX hlavičky Construct the PCX header
' ---------------------------------------------------
Dim hdr As PCXHeader
hdr.Manufacturer = &H0A
hdr.Version = 5
hdr.Encoding = 1
hdr.BitsPerPixel = 1 ' 1 bit na rovinu 1 bit per plane
hdr.XMin = 0
hdr.YMin = 0
hdr.XMax = width - 1
hdr.YMax = height - 1
hdr.HDPI = 300
hdr.VDPI = 300
hdr.ColorMap = colorMap4
hdr.Reserved = 0
hdr.Planes = 2 ' 2 roviny => 2 bity na pixel 2 planes => 2 bits per pixel
hdr.BytesPerLine = bytesPerLine
hdr.PaletteInfo = 1
hdr.HScreenSize = 0
hdr.VScreenSize = 0
hdr.Filler = String$(54, Chr$(0))
' ---------------------------------------------------
' Otevření souboru pro zápis Open file for writing
' ---------------------------------------------------
Dim fileNum As Integer
fileNum = FreeFile
Open fileName For Binary As #fileNum
' Zápis hlavičky Write header
Put #fileNum, , hdr
s = _Source
' -----------------------------------------------------------------------------------------------------------------------
' Zpracování a zápis obrazových dat Process and write image data
' Každý pixel je reprezentován 2 bity, rozdělenými do 2 rovin Each pixel is represented by 2 bits spread across 2 planes
' -----------------------------------------------------------------------------------------------------------------------
Dim planeData(0 To 1) As String
Dim y As Integer, x As Integer
_Source image
For y = 0 To height - 1
' Inicializace dat obou rovin (každý řádek má délku bytesPerLine) Initialize both plane data lines with zeros
planeData(0) = String$(bytesPerLine, Chr$(0))
planeData(1) = String$(bytesPerLine, Chr$(0))
For x = 0 To width - 1
' Načtení pixelu z obrázku – předpokládáme, že obrázek obsahuje pouze 4 barvy (hodnota 0 az 3)
' Get pixel value from image; expected value in range 0 to 3.
Dim colorIndex As Integer
colorIndex = PCXPointer(Point(x, y))
' Pro každou rovinu nastavíme odpovídající bit For each plane, set the corresponding bit
Dim plane As Integer
For plane = 0 To 1
Dim bitVal As Integer
bitVal = _ShR(colorIndex, plane) And 1
If bitVal = 1 Then
Dim byteIndex As Integer, bitIndex As Integer
byteIndex = x \ 8
bitIndex = 7 - (x Mod 8)
Dim currByte As Integer
currByte = Asc(Mid$(planeData(plane), byteIndex + 1, 1))
currByte = currByte Or _ShL(1, bitIndex)
Mid$(planeData(plane), byteIndex + 1, 1) = Chr$(currByte)
End If
Next plane
Next x
' RLE kódování pro obě roviny daného řádku RLE encode each plane for the current line
Dim p As Integer
For p = 0 To 1
Dim rawLine As String, encoded As String
rawLine = planeData(p)
encoded = ""
Dim iPos As Integer
iPos = 1
Do While iPos <= Len(rawLine)
Dim currentByte As Integer, count As Integer
currentByte = Asc(Mid$(rawLine, iPos, 1))
count = 1
Do While (iPos + count <= Len(rawLine)) And (count < 63)
If Asc(Mid$(rawLine, iPos + count, 1)) = currentByte Then
count = count + 1
Else
Exit Do
End If
Loop
If (count = 1) And (currentByte < 192) Then
encoded = encoded + Chr$(currentByte)
Else
encoded = encoded + Chr$(192 + count) + Chr$(currentByte)
End If
iPos = iPos + count
Loop
' Zápis RLE kódovaných dat pro danou rovinu Write encoded data for this plane
Put #fileNum, , encoded
Next p
Next y
_Source s
Close #fileNum
End Sub
' -------------------------------------------------------------------------------------------------------
' SUB SavePCX16Clr – uloží obrázek jako 16barevný (4bitový) PCX soubor.
' SUB SavePCX16Clr – saves the image as a 16-color (4-bit) PCX file.
' Vstupní parametry: image (ukazatel na obrázek s indexovanými hodnotami 0–15), fileName (název souboru)
' Input parameters: image (image pointer with indexed values 0–15), fileName (output file name)
' -------------------------------------------------------------------------------------------------------
Sub SavePCX16Clr (image As Long, fileName As String)
' Získání rozměrů obrázku / Get image dimensions
Dim width As Integer, height As Integer
width = _Width(image)
height = _Height(image)
' Výpočet bajtů na rovinu: (width+7)\8 a zarovnání na sudé číslo Calculate bytes per line and align to even number
Dim bytesPerLine As Integer
bytesPerLine = (width + 7) \ 8
If (bytesPerLine Mod 2) <> 0 Then bytesPerLine = bytesPerLine + 1
status = GetUsedColors(image)
myMask$ = TransformMask
' -----------------------------------------------------------
' Sestavíme paletu 16 EGA barev Build a 16-color EGA palette
' EGA barvy:
' 0: černá (0,0,0)
' 1: modrá (0,0,170)
' 2: zelená (0,170,0)
' 3: cyan (0,170,170)
' 4: červená (170,0,0)
' 5: magenta (170,0,170)
' 6: hnědá (170,85,0)
' 7: světle šedá (170,170,170)
' 8: tmavě šedá (85,85,85)
' 9: jasně modrá (85,85,255)
' 10: jasně zelená (85,255,85)
' 11: jasně cyan (85,255,255)
' 12: jasně červená (255,85,85)
' 13: jasně magenta (255,85,255)
' 14: žlutá (255,255,85)
' 15: bílá (255,255,255)
' ------------------------------
Dim paletteData As String
paletteData = ""
' V PCX 16barevném formátu se standardně očekává EGA paleta, ale zde může být nahrazena barvami z obrázku.
' In PCX 16-color format, the standard EGA palette is expected, but here we use the image's colors.
paletteData = myMask$ + String$(48 - Len(myMask$), Chr$(0))
' ---------------------------------------------
' Sestavení PCX hlavičky Build the PCX header
' ---------------------------------------------
Dim hdr As PCXHeader
hdr.Manufacturer = &H0A
hdr.Version = 5
hdr.Encoding = 1
hdr.BitsPerPixel = 1 ' 1 bit na rovinu 1 bit per plane
hdr.XMin = 0
hdr.YMin = 0
hdr.XMax = width - 1
hdr.YMax = height - 1
hdr.HDPI = 300
hdr.VDPI = 300
hdr.ColorMap = paletteData ' 16 barev (48 bajtů) 16 colors (48 bytes)
hdr.Reserved = 0
hdr.Planes = 4 ' 4 roviny => 4 bity na pixel 4 planes => 4 bits per pixel
hdr.BytesPerLine = bytesPerLine
hdr.PaletteInfo = 1
hdr.HScreenSize = 0
hdr.VScreenSize = 0
hdr.Filler = String$(54, Chr$(0))
' ---------------------------------------------------
' Otevření souboru pro zápis Open file for writing
' ---------------------------------------------------
Dim fileNum As Integer
fileNum = FreeFile
Open fileName For Binary As #fileNum
' Zápis hlavičky do souboru Write header to file
Put #fileNum, , hdr
' -------------------------------------------------------------------------------------------------------------------------
' Zpracování a zápis obrazových dat Process and write image data
' Každý pixel je reprezentován 4 bity – rozdělenými do 4 rovin Each pixel is represented by 4 bits spread across 4 planes
' -------------------------------------------------------------------------------------------------------------------------
Dim y As Integer, x As Integer
Dim planeData(0 To 3) As String
Dim encoded As String
Dim colorIndex As Integer
s = _Source
_Source image
' Procházení řádků Loop through each line
For y = 0 To height - 1
' Inicializace řádku pro všechny 4 roviny Initialize each plane's line with zeros
planeData(0) = String$(bytesPerLine, Chr$(0))
planeData(1) = String$(bytesPerLine, Chr$(0))
planeData(2) = String$(bytesPerLine, Chr$(0))
planeData(3) = String$(bytesPerLine, Chr$(0))
For x = 0 To width - 1
' Získání hodnoty pixelu z obrázku Get pixel value from image
colorIndex = PCXPointer(Point(x, y)) ' Ujistěte se, že hodnota je v rozsahu 0–15 / Ensure the value is in range 0–15.
Dim plane As Integer
For plane = 0 To 3
Dim bitVal As Integer
bitVal = _ShR(colorIndex, plane) And 1 ' Extrahujeme bit odpovídající rovině / Extract the bit for the current plane
If bitVal = 1 Then
Dim byteIndex As Integer, bitIndex As Integer
byteIndex = x \ 8
bitIndex = 7 - (x Mod 8)
Dim currentByte As Integer
currentByte = Asc(Mid$(planeData(plane), byteIndex + 1, 1))
currentByte = currentByte Or _ShL(1, bitIndex)
Mid$(planeData(plane), byteIndex + 1, 1) = Chr$(currentByte)
End If
Next plane
Next x
' Pro každou ze 4 rovin provedeme RLE kódování a zápis do souboru For each plane, RLE encode and write the data
Dim p As Integer
For p = 0 To 3
Dim rawLine As String
rawLine = planeData(p)
encoded = ""
Dim iPos As Integer
iPos = 1
Do While iPos <= Len(rawLine)
currentByte = Asc(Mid$(rawLine, iPos, 1))
count = 1
Do While (iPos + count <= Len(rawLine)) And (count < 63)
If Asc(Mid$(rawLine, iPos + count, 1)) = currentByte Then
count = count + 1
Else
Exit Do
End If
Loop
If (count = 1) And (currentByte < 192) Then
encoded = encoded + Chr$(currentByte)
Else
encoded = encoded + Chr$(192 + count) + Chr$(currentByte)
End If
iPos = iPos + count
Loop
Put #fileNum, , encoded
Next p
Next y
_Source s
Close #fileNum
End Sub
' -------------------------------------------------------------------------------------------
' SUB SavePCX256clr uloží obrázek jako 8bitový (256 barev) PCX soubor.
' SUB SavePCX256clr saves the image as an 8-bit (256-color) PCX file.
' Vstupní parametry: imageHandle (ukazatel na obrázek), fileName (název souboru)
' Input parameters: imageHandle (image pointer), fileName (output file name)
' -------------------------------------------------------------------------------------------
Sub SavePCX256clr (imageHandle As Long, fileName As String)
' Získáme rozměry obrázku z handle Get image dimensions from handle
Dim imgWidth As Integer, imgHeight As Integer
imgWidth = _Width(imageHandle)
imgHeight = _Height(imageHandle)
' Počet bajtů na řádek: u 8-bitového obrázku odpovídá šířce, ale musí být sudé číslo
' For 8-bit images, bytes per line equals the image width (aligned to an even number)
Dim bytesPerLine As Integer
bytesPerLine = imgWidth
If (bytesPerLine Mod 2) <> 0 Then bytesPerLine = bytesPerLine + 1
status = GetUsedColors(imageHandle)
myMask$ = TransformMask
' Příprava PCX hlavičky Prepare PCX header
Dim hdr As PCXHeader
hdr.Manufacturer = &H0A ' PCX identifikátor PCX identifier
hdr.Version = 5 ' Verze Version (e.g., PC Paintbrush 3.0)
hdr.Encoding = 1 ' RLE komprese RLE compression
hdr.BitsPerPixel = 8 ' 8 bitů na pixel 8 bits per pixel
hdr.XMin = 0
hdr.YMin = 0
hdr.XMax = imgWidth - 1
hdr.YMax = imgHeight - 1
hdr.HDPI = 300
hdr.VDPI = 300
hdr.ColorMap = String$(48, Chr$(0)) ' Nepoužitá paleta – vyplněno nulami Unused palette (zeros)
hdr.Reserved = 0
hdr.Planes = 1
hdr.BytesPerLine = bytesPerLine
hdr.PaletteInfo = 1 ' 1 = barevný obrázek/ 1 = color image
hdr.HScreenSize = 0
hdr.VScreenSize = 0
hdr.Filler = String$(54, Chr$(0))
' Otevření souboru pro zápis v binárním režimu Open file in binary mode for writing
Dim fileNum As Integer
fileNum = FreeFile
Open fileName For Binary As #fileNum
' Zápis hlavičky Write header
Put #fileNum, , hdr
' Pro každý řádek obrázku provedeme: For each image line do:
Dim y As Integer, x As Integer, i As Integer
Dim rawLine As String, encodedLine As String
Dim currentByte As Integer, count As Integer
Dim pixelValue As Integer
S = _Source
_Source imageHandle
For y = 0 To imgHeight - 1
' Inicializujeme řádek na požadovanou délku, vyplněný nulami Initialize the line with zeros
rawLine = String$(bytesPerLine, Chr$(0))
' Načteme každý pixel řádku Read each pixel in the row
For x = 0 To imgWidth - 1
pixelValue = PCXPointer(Point(x, y)) ' Vrátí hodnotu (0-255) Returns pixel value (0-255)
Mid$(rawLine, x + 1, 1) = Chr$(pixelValue)
Next x
' RLE kódování řádku dle PCX specifikace RLE encode the line as per PCX specification
encodedLine = ""
i = 1
Do While i <= Len(rawLine)
currentByte = Asc(Mid$(rawLine, i, 1))
count = 1
Do While (i + count <= Len(rawLine)) And (count < 63)
If Asc(Mid$(rawLine, i + count, 1)) = currentByte Then
count = count + 1
Else
Exit Do
End If
Loop
If (count = 1) And (currentByte < 192) Then
encodedLine = encodedLine + Chr$(currentByte)
Else
encodedLine = encodedLine + Chr$(192 + count) + Chr$(currentByte)
End If
i = i + count
Loop
' Zápis RLE kódovaného řádku do souboru Write the RLE encoded line to file
Put #fileNum, , encodedLine
Next y
' Na konci 256barevného PCX souboru se zapisuje paleta: At the end of a 256-color PCX file, the palette is written:
' První bajt je marker (CHR$(12)) a následuje 256x3 bajtů (R, G, B) First byte is a marker (CHR$(12)) followed by 256x3 bytes (R, G, B)
Dim marker As String * 1
marker = Chr$(12)
Put #fileNum, , marker
Dim paletteStr As String
paletteStr = myMask$
Put #fileNum, , paletteStr
_Source S
Close #fileNum
End Sub
' -------------------------------------------------------------------------------------------
' SUB SavePCX24 – uloží obrázek jako 24bitový PCX soubor.
' SUB SavePCX24 – saves the image as a 24-bit PCX file.
' Vstupní parametry: imageHandle (ukazatel na obrázek), fileName (název souboru)
' Input parameters: imageHandle (image pointer), fileName (output file name)
' -------------------------------------------------------------------------------------------
Sub SavePCX24 (imageHandle As Long, fileName As String)
' Získáme rozměry obrázku z handle Get image dimensions from the image handle
Dim imgWidth As Integer, imgHeight As Integer
imgWidth = _Width(imageHandle)
imgHeight = _Height(imageHandle)
' Počet bajtů na řádek pro každou rovinu – šířka obrázku, ale musí být zarovnaná na sudé číslo
' For each color plane, bytes per line equals the image width (aligned to even number)
Dim bytesPerLine As Integer
bytesPerLine = imgWidth
If (bytesPerLine Mod 2) <> 0 Then bytesPerLine = bytesPerLine + 1
' --- Příprava PCX hlavičky Prepare PCX header ---
Dim hdr As PCXHeader
hdr.Manufacturer = &H0A ' PCX identifikátor PCX identifier
hdr.Version = 5 ' PC Paintbrush 3.0 (version)
hdr.Encoding = 1 ' RLE kódování RLE encoding
hdr.BitsPerPixel = 8 ' 8 bitů na pixel pro každou rovinu 8 bits per pixel per plane
hdr.XMin = 0
hdr.YMin = 0
hdr.XMax = imgWidth - 1
hdr.YMax = imgHeight - 1
hdr.HDPI = 300
hdr.VDPI = 300
hdr.ColorMap = String$(48, Chr$(0)) ' Nepoužitá paleta – vyplněno nulami Unused palette (all zeros)
hdr.Reserved = 0
hdr.Planes = 3 ' 3 barevné roviny: R, G, B 3 color planes: Red, Green, Blue
hdr.BytesPerLine = bytesPerLine
hdr.PaletteInfo = 1 ' 1 = barevný obrázek 1 = color image
hdr.HScreenSize = 0
hdr.VScreenSize = 0
hdr.Filler = String$(54, Chr$(0))
' --- Otevření souboru pro zápis Open file for writing ---
Dim fileNum As Integer
fileNum = FreeFile
Open fileName For Binary As #fileNum
' Zápis 128 bajtů hlavičky Write 128-byte header
Put #fileNum, , hdr
' --- Procházení jednotlivých řádků obrázku Process each image line ---
Dim y As Integer, x As Integer, i As Integer
Dim rawR As String, rawG As String, rawB As String
Dim encodedR As String, encodedG As String, encodedB As String
Dim currentByte As Integer, count As Integer
Dim col As _Unsigned Long, red As Integer, green As Integer, blue As Integer
S = _Source
_Source imageHandle
For y = 0 To imgHeight - 1
' Inicializace řetězců pro každou rovinu – vyplněno nulami / Initialize each plane's line with zeros
rawR = String$(bytesPerLine, Chr$(0))
rawG = String$(bytesPerLine, Chr$(0))
rawB = String$(bytesPerLine, Chr$(0))
' Projdeme všechny pixely řádku a získáme jednotlivé barevné kanály / For each pixel, extract color channels
For x = 0 To imgWidth - 1
' Získání barvy z obrázku – předpokládáme formát &H00RRGGBB / Get pixel color (assumes format &H00RRGGBB)
col = Point(x, y)
red = (col \ &H10000) And &HFF
green = (col \ &H100) And &HFF
blue = col And &HFF
Mid$(rawR, x + 1, 1) = Chr$(red)
Mid$(rawG, x + 1, 1) = Chr$(green)
Mid$(rawB, x + 1, 1) = Chr$(blue)
Next x
' --- RLE kódování pro rovinu Red RLE encode the Red plane ---
encodedR = ""
i = 1
Do While i <= Len(rawR)
currentByte = Asc(Mid$(rawR, i, 1))
count = 1
Do While (i + count <= Len(rawR)) And (count < 63)
If Asc(Mid$(rawR, i + count, 1)) = currentByte Then
count = count + 1
Else
Exit Do
End If
Loop
If (count = 1) And (currentByte < 192) Then
encodedR = encodedR + Chr$(currentByte)
Else
encodedR = encodedR + Chr$(192 + count) + Chr$(currentByte)
End If
i = i + count
Loop
' --- RLE kódování pro rovinu Green RLE encode the Green plane ---
encodedG = ""
i = 1
Do While i <= Len(rawG)
currentByte = Asc(Mid$(rawG, i, 1))
count = 1
Do While (i + count <= Len(rawG)) And (count < 63)
If Asc(Mid$(rawG, i + count, 1)) = currentByte Then
count = count + 1
Else
Exit Do
End If
Loop
If (count = 1) And (currentByte < 192) Then
encodedG = encodedG + Chr$(currentByte)
Else
encodedG = encodedG + Chr$(192 + count) + Chr$(currentByte)
End If
i = i + count
Loop
' --- RLE kódování pro rovinu Blue RLE encode the Blue plane ---
encodedB = ""
i = 1
Do While i <= Len(rawB)
currentByte = Asc(Mid$(rawB, i, 1))
count = 1
Do While (i + count <= Len(rawB)) And (count < 63)
If Asc(Mid$(rawB, i + count, 1)) = currentByte Then
count = count + 1
Else
Exit Do
End If
Loop
If (count = 1) And (currentByte < 192) Then
encodedB = encodedB + Chr$(currentByte)
Else
encodedB = encodedB + Chr$(192 + count) + Chr$(currentByte)
End If
i = i + count
Loop
' Zápis kódovaných dat do souboru v pořadí: Red, Green, Blue Write encoded planes (R, G, B) to file
Put #fileNum, , encodedR
Put #fileNum, , encodedG
Put #fileNum, , encodedB
Next y
_Source S
Close #fileNum
End Sub
' -------------------------------------------------------------------------------------------
' Function TransformMask$ – transformuje pole UsedColors do řetězce palety.
' Function TransformMask$ – transforms the UsedColors array into a palette string.
' -------------------------------------------------------------------------------------------
Function TransformMask$
For i = 0 To UBound(UsedColors) ' Musí to být od nuly, jinak první barva chybí / Must start from zero so that the first color is not missing!
s$ = s$ + Chr$(UsedColors(i).r) + Chr$(UsedColors(i).g) + Chr$(UsedColors(i).b)
Next i
TransformMask$ = s$
End Function
' -------------------------------------------------------------------------------------------
' Function PCXPointer& – vrací index barvy z masky na základě původní hodnoty.
' Function PCXPointer& – returns the palette index based on the original color value.
' Například: pokud Point vrací 54 a tato barva se v masce nachází na pozici 5, vrátí 5.
' For example: if Point returns 54 and that color is at position 5 in the mask, it returns 5.
' -------------------------------------------------------------------------------------------
Function PCXPointer& (Value As _Unsigned _Byte)
Dim i As Long
i = 0
Do Until UsedColors(i).original = Value
i = i + 1
Loop
PCXPointer = i
End Function
Code: (Select All)
i& = _NewImage(100, 100, 256)
_Dest i&
Cls , 20
For f = 1 To 100
PSet (Rnd * 100, Rnd * 100), Rnd * 255
Next
_Dest 0
Print ClrsCnt(i&)
Function ClrsCnt (handle As Long)
Dim As _Unsigned _Byte r, g, b, r1, g1, b1
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
c(r, g, b) = 1
a = a + 4
Loop
Do Until r1 = 255
g1 = 0
Do Until g1 = 255
b1 = 0
Do Until b1 = 255
If c(r1, g1, b1) Then Clrscn = Clrscn + 1
b1 = b1 + 1
Loop
g1 = g1 + 1
Loop
r1 = r1 + 1
Loop
ClrsCnt = Clrscn
Else
Dim d(255) As _Byte
Do Until a = m.SIZE
d(_MemGet(m, m.OFFSET + a, _Unsigned _Byte)) = 1
a = a + 1
Loop
a = 0
Do Until a = 255
If d(a) Then Clrscn = Clrscn + 1
a = a + 1
Loop
ClrsCnt = Clrscn
End If
End Function
