Convert up to 13 letters, symbols, or numbers into upside-down. 
Strange though how I couldn't use CLS instead of the second Screen NewImage at the bottom, or even after the INPUT line (if I put SCREEN before the DO). It just blacks out the screen for some reason with CLS without making the large text. 

Do

    start:

    Input "Word to make upside-down (up to 13 letters, symbols, or numbers: ", word$

    If Len(word$) > 13 Then GoTo start

    Screen _NewImage(800, 600, 32)

    Locate 1, 32

    Color 1

    Print word$

    letters = Len(word$)

    ll = (letters * 8) - 2

    cent = (_Width / 2)

    For I = 248 To 248 + ll Step .15

        jj = 0

        For j = 15 To 0 Step -.15

            jj = jj + .15

            If Point(I, j) > 0 Then

                Line ((I - 196) * 4, jj * 4 + 50)-((I - 196) * 4 + 2, jj * 4 + 52), _RGB32(0, 0, 0), BF

            Else

                PSet ((I - 196) * 4, jj * 4 + 50), _RGB32(255, 255, 255)

            End If

        Next j

        jj = 0

    Next I

    Sleep

    Screen _NewImage(800, 600, 32)

Loop

There's no graphics. But it lets you choose between 3 and 100 sides of dice and how many dice in one roll. It also keeps tabs on all of your totals, up to 100 rolls. This also uses windows popups for the entire program. Nothing will be on the main window, besides the very end to turn it off. This is an example on how to use windows popups for the messagebox and inputbox$ commands. Enjoy!

'Roll The Dice v.2

'Feb. 19, 2025



'Thank you to EmmasPPM for the ideas to make more than 1 round and to keep a log of the rounds.



Dim dice(100)

Dim a$(100)

Dim totals(100)

_Title "Roll The Dice by SierraKen"

Randomize Timer

Do

    Do



        'How many dice.

        title$ = "Roll The Dice"

        defaultInput$ = " "

        message$ = "How many dice do you wish to roll (1-100)?"

        result$ = _InputBox$(title$, message$, defaultInput$)

        If _Trim$(result$) = "" Then End

        diceam = Val(result$)

        If diceam < 1 Or diceam > 100 Or diceam <> Int(diceam) Then

            _MessageBox "Roll The Dice", "Pick only between 1 and 100."

            Exit Do

        End If



        'How many sides.

        title$ = "How many sides."

        defaultInput$ = " "

        message$ = "How many sides is your dice (3-100)?"

        result$ = _InputBox$(title$, message$, defaultInput$)

        If _Trim$(result$) = "" Then End

        num = Val(result$)

        If num < 3 Or num > 100 Or num <> Int(num) Then

            _MessageBox "How many sides.", "Pick only between 3 and 100."

            Exit Do

        End If



        'Roll The Dice

        For t = 1 To diceam

            dice(t) = Int(Rnd * num) + 1

            a$(t) = Str$(dice(t))

            b$ = b$ + "  [ Dice " + Str$(t) + ": " + a$(t) + " ]  "

            total = total + dice(t)

        Next t

        m$ = b$ + " [ Roll Total: " + Str$(total) + " ]"

        _MessageBox "Roll The Dice", m$



        'Round Totals Window

        rounds = rounds + 1

        totals(rounds) = total

        For r = 1 To rounds

            r$ = r$ + " [ Round " + Str$(r) + ":  " + Str$(totals(r)) + " ]  "

        Next r

        _MessageBox "Dice Round Totals Log", r$

        If rounds = 100 Then

            _MessageBox "Limit Reached", "Your 100 round limit has been reached, feel free to play again."

            End

        End If

        'Clear strings and variable for next round.

        m$ = ""

        a$ = ""

        b$ = ""

        r$ = ""

        total = 0

    Loop

Loop

Based off the topic here: https://qb64phoenix.com/forum/showthread.php?tid=3475

Type Ratio_Type

    x As _Integer64

    y As _Integer64

    description As String

    size As _Integer64

    scale As _Integer64

    total As _Integer64

    empty As _Integer64

End Type



Dim Shared Ratio(8) As Ratio_Type

Dim As Long items

Screen _NewImage(1280, 720, 32)



InitRatios

Do

    Cls

    Input "Enter the number of items =>"; items

    If items <= 0 Then System

    CalculateGrids items

    SortGrids

    DisplayGrids

    Print: Print "Press <ANY KEY> to restart"

    pause$ = Input$(1)

Loop



Sub DisplayGrids

    Print

    Color &HFF00FF00&&

    Print "Description                                                      Ratio  Scaler  Grid  Empty"

    Color &HFFFFFFFF&&

    format$ = "\                                                              \  ##:##    ###    ##x##  ### "

    For i = 1 To UBound(Ratio)

      ? using format$;ratio(i).description,ratio(i).x,ratio(i).y, ratio(i).scale, ratio(i).x*ratio(i).scale,_

              ratio(i).y*ratio(i).scale, ratio(i).empty

    Next

End Sub



Sub SortGrids

    For i = 1 To UBound(Ratio)

        For j = i + 1 To UBound(Ratio)

            If Ratio(i).empty > Ratio(j).empty Then Swap Ratio(i), Ratio(j)

    Next j, i

End Sub



Sub CalculateGrids (items)

    For i = 1 To UBound(Ratio)

        n = 1

        Do Until Ratio(i).size * n ^ 2 >= items

            n = n + 1

        Loop

        Ratio(i).scale = n 'this is the scaler

        Ratio(i).total = Ratio(i).size * n ^ 2 'this is the total number of cells

        Ratio(i).empty = Ratio(i).total - items

    Next

End Sub



Sub InitRatios

    RatioData:

    Data 1,1,Square (profile pictures; social media)

    Data 2,3,Classic 35mm (4x6; 6x9; etc.)

    Data 5,7,5 x 7 photo

    Data 17,22,Standard letter size (8.5x11)

    Data 4,3,Older PC monitor + analog TV (640x480; 1024x768; etc.)

    Data 4,5,Art prints + medium format (8x10; 16x20)

    Data 11,14,legal paper (11x14)

    Data 16,9,Standard HD display (1920x1080; 1280x720; etc.)

    For i = 1 To UBound(Ratio)

        Read Ratio(i).x, Ratio(i).y, Ratio(i).description

        Ratio(i).size = Ratio(i).x * Ratio(i).y

    Next

End Sub

This may be a dumb question, but how do you "tag" a user in a forum post, outside of quoting them directly in a reply? In the past I found where someone tagged someone and clicked reply and copied the source for the "tag". I would expect in the editor something like typing @ followed by one or more letters would bring up a list of users, which you narrow down by typing more letters, and then clicking the user you want to tag. But that doesn't work here, and I don't see a toolbar button to tag a user, and I haven't found anything on the help page about it, so maybe I'm missing something. Is there a handy dandy way to tag a user in a post?

Input then in the routine, press backspace to rerun, Esc to quit, or any other inkey$ recognized key to toggle from active to idle and back. Background dims when idle.

img& = _LoadImage("activate-static.png", 32)

h1& = _CopyImage(img&, 33)

_FreeImage img&

Palette 5, 63: Cls

Input "0 or 1 to 120 for _limit _autodisplay demo: ", try

Color 12, 5: Cls

Locate , 40, 1, 7, 1

Print "Steve is ";

If try Then a = try Else a = 30

Do

    _Limit a

    b$ = InKey$

    If Len(b$) Then

        If b$ = Chr$(8) Then Run

        If b$ = Chr$(27) Then System

        skip = Not skip

        If skip Then Palette 5, 7: _PutImage (0, 0), h1&: _Display Else Palette 5, 63

    End If

    If skip = 0 Then

        _PutImage (0, 0), h1&: _Display ' Normal display flow.

    Else

        If try Then ' If try = 0 (input 0 at start) we skip any further display, which suspends the flashing cursor!

            _PutImage (0, 0), h1& ' How the hell can we get rid of this, but still have the image show up?

            _AutoDisplay ' Just for fun. This should be _Display but what's interesting is _AutoDisplay is similar, except you need to input 30 or higher so it doesn't flicker. _Display doesn't ever flicker.

        End If

    End If

Loop

Thanks to Steve and BPlus for helping figure out the ratio math. 
I don't know if this is the most efficient code, but it seems to work... 

I'm rethinking the use of hardware acceleration in SCREEN 0. The reason is the very high CPU readings. A lot of times business apps just sit open all day, and I can't imagine burning up the insides of a computer by refreshing hardware images all the time the system sits idle. This leave us with solutions like the old days of using a timed screensaver. I don't miss those days. Another, and more complex method, would be checking for idle time and making a copy of the current page, calling up a graphics screen, and using that to display the image while routing everything else to the mouse/keyboard subroutine. When some action is detected, the process would have to reconstruct the current screen in SCREEN 0... and that could be a real PITA.

For pure graphics uses for speed in gaming, moving multiple objects around the screen, even for complex screen scrolling events, you can't beat hardware acceleration, but mixing it with SCREEN 0 does come at a hefty CPU price, which has me leaning in the direction of graphics conversion for a few apps I want to update.

So I'm curious, what have those of you who have tried this feature think?

Pete

I found a few things that _SaveFile can't do, so I'll add them here gradually. One thing every day. So first thing. Black and white BMP. Yeah. Amazing 1-bit, uncompressed BMP. In this type of BMP, compression is not supported. Maybe the compression can be partially considered the fact that each pixel in the file takes up 1 bit. The advantage of BMP over PCX is that BMP accepts any two colors.

About the program. Of course, it includes the ability to save the file. It can also open the file through its own loader, without LoadImage. There is also a image viewer (I borrowed that from my game Puzzle) and a program for setting the contrast of the input image. When setting the contrast, even thousandths matter and the output image changes rapidly. Then there is a SUB in the program for finding two suitable colors for the mask - but if you want it to be nice, you have to adjust the contrast. Of course, you can also enter the colors manually, there are only two.
Why is there a custom Loader in the program. I had an error in the file header and _LoadImage refused to open it. That's why I thought it simply didn't support it. So I wrote a loader that also smoothed the image. The result is exactly the same image as in the photo viewer. It was only when I wrote my own loader that I figured it out and fixed it. Well, never mind. My loader supports smoothing, _LoadImage doesn't. Unfortunately, smoothing comes at the expense of speed if you use large image sizes.

'SET SOURCE IMAGE NAME (ROW 50)!                                                  BMP 1 bit Example Program



'                                                          **********************************

'                                                            Program pro uložení 1-bitové  BMP

'                                                            Program for saving a 1-bit BMP

'                                                          **********************************



'                                                                --- Struktura pro BMP (File Header + Info Header + 2 maskové záznamy) ---

'                                                                --- Structure for BMP (File Header + Info Header + 2 mask records) ---

Type BW

    ' Header / Záhlaví

    signature As String * 2 '                                        "BM" (konstantní signatura)    "BM" (constant signature)

    FileSize As Long '                                                Velikost souboru v bajtech    File size in bytes

    Res1 As Integer '                                                    Rezervováno, nepoužito    Reserved (not used)

    Res2 As Integer '                                                    Rezervováno, nepoužito    Reserved (not used)

    DataOffset As Long '                    Offset k pixelovým datům (vždy 62 u tohoto typu BMP)    Offset to pixel data (always 62 in this BMP type)



    ' InfoHeader / Informace o obrázku

    SizeOfInfoHeader As Long '                                                    Vždy 40 bajtů    Always 40 bytes

    Width As Long '                                                                Šířka obrázku    Image width

    Height As Long '                                                              Výška obrázku    Image height

    Planes As Integer '                                                      Počet rovin, vždy 1    Number of planes, always 1

    BitsPerPixel As Integer '                                  Hloubka bitů na pixel (zde 1 bit)    Bits per pixel (here 1 bit)

    Compression As Long '                                                  Komprese (0 = žádná)    Compression (0 = none)

    ImageSize As Long '                      Velikost obrázku (u nekomprimovaných obrázků je 0)    Image size (0 for uncompressed)

    XPixels As Long '                                          Horizontální rozlišení (pixely/m)    Horizontal resolution (pixels per meter)

    YPixels As Long '                                            Vertikální rozlišení (pixely/m)    Vertical resolution (pixels per meter)

    ColorsUsed As Long '                                    Použité barvy (0 = všechny z palety)    Colors used (0 means all colors from palette)

    ImportantColors As Long '                                      Důležité barvy (0 = všechny)    Important colors (0 = all)



    '                                                                                Color table    Paleta (2 záznamy pro 2 barvy obrázku)

    ColorA As _Unsigned Long '                                    První barva (obvykle popředí)    First color (usually foreground)

    ColorB As _Unsigned Long '                                      Druhá barva (obvykle pozadí)    Second color (usually background)

End Type



Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)



_FullScreen







'******************************************************

' Hlavní program

' Main program

'******************************************************



' VERY IMPORTANT!!!

' VELMI DŮLEŽITÉ!!!



imageO = _LoadImage("6.jpg", 256) '                                          If you use _LoadImage xxxx.jpg, 32, go to SUB SaveBMP1 and set luminance = (77 * Red + 150 * Green + 29 * Blue) \ 256.

'                                                                            Then set correct Contrast for optimal output.



'                                                                            Načtení obrázku "6.jpg" - ideálně by měl být načten jako 8-bitový obrázek.

'                                                                            Load the image "6.jpg" - best result when loaded as an 8-bit image.

'                                                                            Tento JPG je 32-bitový; QB64PE použije vestavěnou konverzi pro nejlepší kvalitu.

'                                                                            This JPG is 32-bit; QB64PE uses built-in conversion for optimal quality.



Print "Set Contrast..." '                                                    Nastavení kontrastu obrázku    Setting image contrast

SetContrast imageO, 1 '.11 ' 1 is default contrast some imeges needs              Volání funkce SetContrast s hodnotou 1    Call SetContrast function with value 1

'                              contrast higher - try and see

Print "Detect mask colors..." '                                              Detekce maskovacích barev (např. černá a bílá)

'                                                                            Detect mask colors (e.g., black and white) - HERE IS 5 OPTIONS for detecting mask images

If ClrsCnt(imageO) > 2 Then

    DetectMaskColors imageO, 5, backGroundColor~&, foregroundColor~& '      Options in DetectMaskColors: 5 = use default mask color Black and White

    '                                                                                                    4 = Colors with medium brightness

    '                                                                                                    3 = Two most contrating colors

    '                                                                                                    2 = Darkest and brightest colors

    '                                                                                                    1 = Two most frequent colors



    '                                                                        Pokud obrázek obsahuje více než 2 barvy, detekuje maskovací barvy pomocí režimu 5 (černá a bílá).

    '                                                                        If the image has more than 2 colors, detect mask colors using mode 5 (black and white).

End If



Print "Save image..." '                                                      Uložení obrázku jako 1-bit BMP    Saving image as 1-bit BMP

SaveBMP1 imageO, "Bitmap1.bmp", foregroundColor~&, backGroundColor~&

'                                                                            Uloží obrázek imageO do souboru "Bitmap1.bmp" s danými barvami popředí a pozadí.

'                                                                            Save imageO to file "Bitmap1.bmp" with specified foreground and background colors.



Print "Load and make smooth...." '                                          Načtení BMP a aplikace vyhlazení    Load BMP and apply smoothing

image = LoadAndSmoothBMP1Bit("Bitmap1.bmp")

'                                                                            Načte 1-bit BMP pomocí vlastní funkce, protože _LoadImage nepodporuje 1-bitové BMP.

'                                                                            Load 1-bit BMP using a custom function since _LoadImage does not accept 1-bit BMPs.



ViewImage image '                                                            Zobrazení obrázku na obrazovce    Display the image

Print "Press key for "

Print "LoadImage output."

Sleep

_FreeImage image

image = _LoadImage("Bitmap1.bmp")

ViewImage image

Print "Without Smmoothing"

Print "Press key..."

Sleep

_FreeImage imageO

Clear

End







'******************************************************

' Subrutina pro zobrazení obrázku

' Subroutine to display the image (with scaling)

'******************************************************

Sub ViewImage (Img As Long)





    '                                                                      Calculate the difference between image dimensions and desktop dimensions.

    SpcV_DeltaW = Abs(_Width(Img) - _DesktopWidth) '                        Rozdíl šířky obrázku a desktopu    Difference in width between image and desktop

    SpcV_DeltaH = Abs(_Height(Img) - _DesktopHeight) '                      Rozdíl výšky obrázku a desktopu    Difference in height between image and desktop



    ' Vypočítá procentuální rozdíl

    ' Calculate percentage difference

    SpcV_PercW = SpcV_DeltaW / (_Width(Img) / 100) '                        Procentuální rozdíl šířky    Percentage difference in width

    SpcV_PercH = SpcV_DeltaH / (_Height(Img) / 100) '                      Procentuální rozdíl výšky    Percentage difference in height



    ' Volba vyššího procenta

    ' Choose the higher percentage

    If SpcV_PercW > SpcV_PercH Then

        SpcV_P = SpcV_PercW

    Else

        SpcV_P = SpcV_PercH

    End If

    SpcV_P = SpcV_P / 100



    '                                                                      Výpočet konečného poměru pro změnu velikosti obrázku

    '                                                                      Calculate final scaling ratio for the image

    If _Width(Img) > _DesktopWidth And _Height(Img) > _DesktopHeight Then

        FinalRatio = 1 - SpcV_P '                                          Downsizing, pokud je obrázek větší ve všech směrech    Downsizing if image is larger in both dimensions

    End If



    If _Height(Img) < _DesktopHeight And _Width(Img) < _DesktopWidth Then

        FinalRatio = _DesktopHeight / _Height(Img) '                        Upsizing, pokud je obrázek menší než výška desktopu    Upsizing if image is smaller than desktop height

    End If



    If _Height(Img) > _DesktopHeight And _Width(Img) < _DesktopWidth Then

        SpcV_PercH = SpcV_DeltaH / (_Height(Img) / 100)

        SpcV_PercH = SpcV_PercH / 100

        FinalRatio = 1 - SpcV_PercH '                                      Downsizing, pokud je obrázek vyšší než desktop    Downsizing if image height exceeds desktop height

    End If



    If _Height(Img) < _DesktopHeight And _Width(Img) > _DesktopWidth Then

        SpcV_PercW = SpcV_DeltaW / (_Width(Img) / 100)

        SpcV_PercW = SpcV_PercW / 100

        Beep

        FinalRatio = 1 - SpcV_PercW '                                      Downsizing, pokud je obrázek širší než desktop    Downsizing if image width exceeds desktop width

    End If



    If _Height(Img) = _DesktopHeight And _Width(Img) = _DesktopHeight Then

        FinalRatio = 1 '                                                    Pokud jsou rozměry shodné, ponech poměr 1    If dimensions match, keep scale 1

    End If



    '                                                                      Výpočet nových rozměrů a centrování obrázku

    '                                                                      Calculate new dimensions and center the image on the screen

    SpcV_W = FinalRatio * _Width(Img) '                                    Nová šířka obrázku    New image width

    SpcV_H = FinalRatio * _Height(Img) '                                    Nová výška obrázku    New image height

    SpcV_DeltaX = (_DesktopWidth - SpcV_W) \ 2 '                            Horizontální posun pro centrování    Horizontal offset to center the image



    _PutImage (SpcV_DeltaX, 0)-(SpcV_DeltaX + SpcV_W, SpcV_H), Img&, 0 '    Zobrazení obrázku na přepočítané pozici a rozměrech

    '                                                                      Display the image at calculated position and size

End Sub







'******************************************************

' Subrutina pro nastavení kontrastu obrázku

' Subroutine to adjust image contrast

'******************************************************

Sub SetContrast (handle As Long, value)

    '                                                                      handle: identifikátor obrázku    image handle

    '                                                                      value: hodnota kontrastu (0 až 5; 5 = 500% kontrastu)    value in range 0 to 5; 5 means 500% contrast



    Dim m As _MEM

    Dim a As Long

    Dim As _Unsigned Long newC

    Dim As _Unsigned _Byte r, g, b, c, NewR, NewG, NewB



    m = _MemImage(handle) '                                                  Získání paměťové struktury obrázku    Get the memory structure of the image



    Select Case _PixelSize(handle)

        Case 1 '                                                            Pro 8-bitový obrázek (paletový)  For 8 bit image

            Do Until a = m.SIZE

                _MemGet m, m.OFFSET + a, c '                                Načtení indexu palety    Retrieve palette index



                r = _Red32(_PaletteColor(c, handle))

                g = _Green32(_PaletteColor(c, handle))

                b = _Blue32(_PaletteColor(c, handle))



                '                                                            Aplikace kontrastu na jednotlivé barevné kanály

                '                                                            Apply contrast adjustment on each channel

                NewR = (r - 128) * value + 128

                NewG = (g - 128) * value + 128

                NewB = (b - 128) * value + 128



                '                                                            Ošetření přetečení a podtečení (hranice 0-255)

                '                                                            Clamp values to 0-255 range

                If NewR > 255 Then NewR = 255

                If NewR < 0 Then NewR = 0

                If NewG > 255 Then NewG = 255

                If NewG < 0 Then NewG = 0

                If NewB > 255 Then NewB = 255

                If NewB < 0 Then NewB = 0



                newC = _RGB32(NewR, NewG, NewB)

                _PaletteColor c, newC, handle



                a = a + 1

            Loop



        Case 4 '                                                              Pro 32-bitový obrázek  For 32 bit image

            Do Until a = m.SIZE

                _MemGet m, m.OFFSET + a, b

                _MemGet m, m.OFFSET + a + 1, g

                _MemGet m, m.OFFSET + a + 2, r



                NewR = (r - 128) * value + 128

                NewG = (g - 128) * value + 128

                NewB = (b - 128) * value + 128



                If NewR > 255 Then NewR = 255

                If NewR < 0 Then NewR = 0

                If NewG > 255 Then NewG = 255

                If NewG < 0 Then NewG = 0

                If NewB > 255 Then NewB = 255

                If NewB < 0 Then NewB = 0



                _MemPut m, m.OFFSET + a, NewB

                _MemPut m, m.OFFSET + a + 1, NewG

                _MemPut m, m.OFFSET + a + 2, NewR



                a = a + 4

            Loop

    End Select

End Sub







'******************************************************                      Speed - up updated function - from PCX thread

' Funkce pro spočítání počtu barev v obrázku

' Function to count the number of colors in the image (8-bit and 32-bit)

'******************************************************

Function ClrsCnt (handle As Long)

    '                                                                        Vrátí počet unikátních barev v obrázku

    '                                                                        Returns the count of unique colors in the image

    Dim As _Unsigned _Byte r, g, b

    Dim As _MEM m

    Dim As Long a, Clrscn

    m = _MemImage(handle)



    If _PixelSize(handle) > 1 Then

        Dim c(255, 255, 255) As _Unsigned _Byte

        Do Until a = m.SIZE

            _MemGet m, m.OFFSET + a, b

            _MemGet m, m.OFFSET + a + 1, g

            _MemGet m, m.OFFSET + a + 2, r

            a = a + 4

            If c(r, g, b) = 0 Then

                Clrscn = Clrscn + 1

                c(r, g, b) = 1

            End If

        Loop

        ClrsCnt = Clrscn

    Else

        Dim d(255) As _Byte

        Do Until a = m.SIZE

            index = _MemGet(m, m.OFFSET + a, _Unsigned _Byte)

            If d(index) = 0 Then

                d(index) = 1

                Clrscn = Clrscn + 1

            End If

            a = a + 1

        Loop

        ClrsCnt = Clrscn

    End If

End Function







'******************************************************

' Subrutina pro detekci maskovacích barev

' Subroutine to detect mask colors based on a given mode

'******************************************************

Sub DetectMaskColors (handle As Long, mode As Integer, color1 As _Unsigned Long, color2 As _Unsigned Long)

    '                                                                                                            Detekuje maskovací barvy podle zvoleného režimu

    '                                                                                                            Detects mask colors according to the selected mode

    Dim m As _MEM

    Dim a As Long

    Dim As _Unsigned _Byte r, g, b, c, brightness

    Dim colorCount(255) As Long '                                                                                Histogram pro paletový obrázek    Histogram for paletted image

    Dim brightnessHist(255) As Long '                                                                            Histogram světlosti    Histogram for brightness

    Dim totalBrightness As Long

    Dim totalPixels As Long

    Dim isPaletted As _Unsigned _Byte



    m = _MemImage(handle)



    If _PixelSize(handle) = 1 Then

        isPaletted = 1 '                                                                                          8-bitový obrázek (paletový)    8-bit paletted image

        '                                                                                                        Projdeme paletové barvy

        '                                                                                                        Loop through palette colors

        a = 0

        Do Until a >= m.SIZE

            _MemGet m, m.OFFSET + a, c '                                                                          Načtení indexu palety    Get palette index

            brightness = (0.3 * _Red32(_PaletteColor(c, handle)) + 0.59 * _Green32(_PaletteColor(c, handle)) + 0.11 * _Blue32(_PaletteColor(c, handle)))

            brightnessHist(brightness) = brightnessHist(brightness) + 1

            colorCount(c) = colorCount(c) + 1

            totalBrightness = totalBrightness + brightness

            totalPixels = totalPixels + 1

            a = a + 1

        Loop

    End If

    _MemFree m



    If totalPixels = 0 Then totalPixels = 1 '                                                                        Ochrana proti dělení nulou    Prevent division by zero



    Select Case mode

        Case 1 '                                                                                                    Nejčastější dvě barvy    Two most frequent colors

            Dim max1 As Long, max2 As Long, idx1 As _Unsigned _Byte, idx2 As _Unsigned _Byte

            For a = 0 To 255

                If colorCount(a) > max1 Then

                    max2 = max1

                    idx2 = idx1

                    max1 = colorCount(a)

                    idx1 = a

                ElseIf colorCount(a) > max2 Then

                    max2 = colorCount(a)

                    idx2 = a

                End If

            Next

            color1 = _PaletteColor(idx1, handle)

            color2 = _PaletteColor(idx2, handle)



        Case 2 '                                                                                                      Nejtmavší a nejsvětlejší barva    Darkest and brightest colors

            Dim minIdx As _Unsigned _Byte, maxIdx As _Unsigned _Byte

            For a = 0 To 255

                If brightnessHist(a) > 0 Then

                    minIdx = a

                    Exit For

                End If

            Next

            For a = 255 To 0 Step -1

                If brightnessHist(a) > 0 Then

                    maxIdx = a

                    Exit For

                End If

            Next

            color1 = _PaletteColor(minIdx, handle)

            color2 = _PaletteColor(maxIdx, handle)



        Case 3 '                                                                                                        Nejkontrastnější dvě barvy    Two most contrasting colors

            Dim best1 As _Unsigned _Byte, best2 As _Unsigned _Byte, maxContrast As Long

            For a = 0 To 255

                For b = a + 1 To 255

                    Dim contrast As Long

                    contrast = Abs(a - b)

                    If contrast > maxContrast Then

                        maxContrast = contrast

                        best1 = a

                        best2 = b

                    End If

                Next

            Next

            color1 = _PaletteColor(best1, handle)

            color2 = _PaletteColor(best2, handle)



        Case 4 '                                                                                                            Barvy se střední světlostí    Colors with medium brightness

            Dim middleBrightness As Long

            middleBrightness = totalBrightness \ totalPixels

            Dim closest1 As _Unsigned _Byte, closest2 As _Unsigned _Byte, minDiff1 As Long, minDiff2 As Long

            minDiff1 = 256

            minDiff2 = 256

            For a = 0 To 255

                Dim diff As Long

                diff = Abs(a - middleBrightness)

                If diff < minDiff1 Then

                    minDiff2 = minDiff1

                    closest2 = closest1

                    minDiff1 = diff

                    closest1 = a

                ElseIf diff < minDiff2 Then

                    minDiff2 = diff

                    closest2 = a

                End If

            Next

            color1 = _PaletteColor(closest1, handle)

            color2 = _PaletteColor(closest2, handle)



        Case 5 ' P                                                                                                            evně nastavené: Černá a bílá    Fixed mode: Black and White

            color1 = _RGB32(0, 0, 0)

            color2 = _RGB32(255, 255, 255)

    End Select

End Sub







'*********************************************************************************************

' Subrutina pro uložení 1-bit BMP souboru

' Subroutine to save a 1-bit BMP file (uncompressed), 1Bit BMP do not support RLE compression.

'*********************************************************************************************

Sub SaveBMP1 (imageRef As Long, fileName As String, Fgc As _Unsigned Long, Bgc As _Unsigned Long)

    ' Parametry:

    ' imageRef - identifikátor obrázku    image handle

    ' fileName - název souboru    output file name

    ' Fgc - barva popředí (foreground)    foreground color

    ' Bgc - barva pozadí (background)    background color





    Dim W As Long, H As Long, Wo As Long

    Wo = _Width(imageRef) '              Původní šířka obrázku    Original image width

    H = _Height(imageRef) '                      Výška obrázku    Image height



    '                                  Uprav šířku, aby byla dělitelná 32 (nutné pro řádkové zarovnání BMP)

    '                                  Adjust width to be divisible by 32 (required for BMP row alignment)

    Do Until Wo Mod 32 = 0

        Wo = Wo + 1

    Loop

    W = Wo



    '                                  Vytvoř nový obrázek s upravenou šířkou

    '                                  Create a new image with adjusted width

    Dim newImage As Long

    newImage = _NewImage(W, H, 32)

    Dim clr As _Unsigned Long

    clr~& = &HFFFFFFFF '              Barva pozadí (např. bílá)    Background color (e.g., white)

    _Dest newImage

    Cls , clr~&



    '                                  Zkopíruj původní obrázek do nového s novými rozměry

    '                                  Copy original image into new image with adjusted dimensions

    _PutImage (0, 0), imageRef, newImage, (0, H)-(W, 0)



    '                                (Volitelně) Uvolni původní obrázek, pokud již není potřeba

    '                                  Optionally free the original image if no longer needed:

    _FreeImage imageRef



    '                                Vypočítej celkovou velikost BMP souboru (62 bajtů = velikost záhlaví)

    '                                Calculate total file size (header size is 62 bytes)

    Dim Size As Long

    Size = _Ceil(W * H / 8) + 62



    '                                Naplň strukturu BMP hlavičky

    '                                Fill in BMP header structure

    Dim BMP1 As BW

    BMP1.signature = "BM"

    BMP1.FileSize = Size

    BMP1.DataOffset = 62

    BMP1.SizeOfInfoHeader = 40

    BMP1.Width = W

    BMP1.Height = H

    BMP1.Planes = 1 '

    BMP1.BitsPerPixel = 1 '

    BMP1.Compression = 0

    BMP1.ImageSize = Size - 62

    BMP1.XPixels = 0

    BMP1.YPixels = 0

    BMP1.ColorsUsed = 0

    BMP1.ImportantColors = 0

    BMP1.ColorA = Fgc '                  Foreground barva    Foreground color

    BMP1.ColorB = Bgc '                  Background barva    Background color



    '                                    Převod obrázku na řádky 1-bitové bitmapy (každý byte reprezentuje 8 pixelů)

    '                                    Convert the image into 1-bit bitmap data (each byte represents 8 pixels)

    Dim m As _MEM

    m = _MemImage(newImage)



    Dim BW_Image(m.SIZE \ 8) As _Unsigned _Byte

    Dim i As Long, j As Long, px As Long

    i& = 0: j = 0



    Do Until i& >= m.SIZE

        Dim Nibble As _Unsigned _Byte

        Nibble = 0

        For px = 0 To 7

            If i& + px + 4 > m.SIZE Then Exit Do

            Dim Red As _Unsigned _Byte, Green As _Unsigned _Byte, Blue As _Unsigned _Byte

            Red = _MemGet(m, m.OFFSET + i& + 3 + px * 4, _Unsigned _Byte)

            Green = _MemGet(m, m.OFFSET + i& + 2 + px * 4, _Unsigned _Byte)

            Blue = _MemGet(m, m.OFFSET + i& + 1 + px * 4, _Unsigned _Byte)



            Dim luminance As Long

            luminance = (77 * Red + 150 * Green + 29 * Blue) And 2048 'modified!



            If luminance < 128 Then

                Nibble = _SetBit(Nibble, 7 - px)

            End If

        Next

        BW_Image(j) = Nibble

        i& = i& + 8 * 4

        j = j + 1

    Loop



    '                                  Odstranění existujícího souboru, pokud již existuje

    '                                  Delete the file if it already exists

    If _FileExists(fileName) Then Kill fileName



    '                                  Uložení BMP souboru do disku

    '                                  Write the BMP file to disk

    Open fileName For Binary As #1

    Put #1, 1, BMP1

    Put #1, 63, BW_Image()

    Close #1



    '                                  Uvolnění prostředků

    '                                  Free resources

    ReDim BW_Image(0)

    _FreeImage newImage

End Sub







'******************************************************

' Definice typů pro BMP formát

' Definitions for BMP format types

'******************************************************



Type BMPHEADER

    signature As String * 2 '            "BM" – signatura souboru    "BM" – file signature

    filesize As Long '                    Velikost souboru v bajtech    File size in bytes

    reserved1 As Integer '                Rezervováno    Reserved (16-bit)

    reserved2 As Integer '                Rezervováno    Reserved (16-bit)

    dataoffset As Long '    Offset k pixelovým datům    Offset to pixel data

End Type



Type BMPINFOHEADER

    headersize As Long '    záhlaví (obvykle 40 bajtů)    Header size (usually 40 bytes)

    width As Long '                      Šířka obrázku    Image width

    height As Long '                      Výška obrázku    Image height

    planes As Integer '            Počet rovin (vždy 1)    Number of planes (always 1)

    bitcount As Integer '        Hloubka bitů na pixel    Bits per pixel

    compression As Long '          Komprese (0 = žádná)    Compression (0 = none)

    imagesize As Long '                Velikost obrázku    Image size

    xpixels As Long '            Horizontální rozlišení    Horizontal resolution

    ypixels As Long '              Vertikální rozlišení    Vertical resolution

    colorsused As Long '          Počet barev v paletě    Colors used in the palette

    importantcolors As Long '            Důležité barvy    Important colors

End Type



Type BMPColor

    blue As _Unsigned _Byte '              Modrá složka    Blue component

    green As _Unsigned _Byte '            Zelená složka    Green component

    red As _Unsigned _Byte '            Červená složka    Red component

    reserved As _Unsigned _Byte '          Rezervováno    Reserved

End Type







'******************************************************

' Funkce pro načtení 1-bit BMP souboru

' Function to load a 1-bit BMP file

'******************************************************

Function LoadBMP1Bit& (fileName As String)

    Dim header As BMPHEADER

    Dim info As BMPINFOHEADER

    Dim pal(1) As BMPColor



    Open fileName For Binary As #1



    '                              Načtení BMP hlavičky (14 bajtů)

    '                              Read BMP file header (14 bytes)

    Get #1, , header

    If header.signature <> "BM" Then

        Print "Chyba: Soubor není BMP." ' Error: File is not a BMP.

        Close #1

        LoadBMP1Bit = 0

        Exit Function

    End If



    '                              Načtení BITMAPINFOHEADER (40 bajtů)

    '                              Read BITMAPINFOHEADER (40 bytes)

    Get #1, , info

    If info.bitcount <> 1 Then

        Print "Chyba: BMP není 1bitový." ' Error: BMP is not 1-bit.

        Close #1

        LoadBMP1Bit = 0

        Exit Function

    End If



    '                                    Načtení palety (2 barvy)

    '                                    Read the color palette (2 colors)

    For i = 0 To 1

        Get #1, , pal(i)

    Next i



    '                                    Výpočet velikosti jednoho řádku (včetně paddingu na 4 bajty)

    '                                    Calculate the size of one row (with 4-byte padding)

    Dim bytesPerRow As Long

    bytesPerRow = (info.width + 7) \ 8

    Dim rowSize As Long

    rowSize = ((bytesPerRow + 3) \ 4) * 4



    Dim totalBytes As Long

    totalBytes = rowSize * info.height



    '                                  Načtení pixelových dat

    '                                  Read pixel data

    ReDim ddata(totalBytes - 1) As _Unsigned _Byte

    Seek #1, header.dataoffset '        Nastavení pozice na začátek pixelových dat    Set file pointer to pixel data offset

    Get #1, , ddata()

    Close #1



    '                                  Vytvoření 32-bitového obrázku pro výstup

    '                                  Create a 32-bit image for output

    Dim img As Long

    img = _NewImage(info.width, info.height, 32)



    '                                  Vytvoření pole pro výsledné pixely

    '                                  Create an array for the resulting pixels

    ReDim pixels(info.width * info.height - 1) As _Unsigned Long



    '                                  Definice masky bitů (od MSB po LSB)

    '                                  Define bit masks (from MSB to LSB)

    Dim bitMasks(7) As _Unsigned _Byte

    bitMasks(0) = &H80

    bitMasks(1) = &H40

    bitMasks(2) = &H20

    bitMasks(3) = &H10

    bitMasks(4) = &H08

    bitMasks(5) = &H04

    bitMasks(6) = &H02

    bitMasks(7) = &H01



    '                                  Rozložení pixelových dat do pole pixelů

    '                                  Decompose pixel data into pixel array

    Dim y As Long, b As Long, bit As Long

    Dim rowIndex As Long, rowOffset As Long, x As Long, pixelIndex As Long

    Dim currentByte As _Byte

    Dim col As _Unsigned Long



    For y = 0 To info.height - 1

        rowIndex = info.height - 1 - y ' BMP data jsou uložena zdola nahoru    BMP stores rows from bottom to top

        rowOffset = rowIndex * rowSize

        For b = 0 To bytesPerRow - 1

            currentByte = ddata(rowOffset + b)

            For bit = 0 To 7

                x = b * 8 + bit

                If x >= info.width Then Exit For

                pixelIndex = y * info.width + x



                If (currentByte And bitMasks(bit)) <> 0 Then

                    col = _RGB32(pal(1).red, pal(1).green, pal(1).blue)

                Else

                    col = _RGB32(pal(0).red, pal(0).green, pal(0).blue)

                End If

                pixels(pixelIndex) = col

            Next bit

        Next b

    Next y



    ' Přenos pixelů do vytvořeného obrázku

    ' Copy pixel data into the image

    Dim m As _MEM, n As _MEM

    m = _MemImage(img)

    Dim numBytes As Long

    numBytes = info.width * info.height * 4

    n = _Mem(pixels())

    _MemCopy n, n.OFFSET, numBytes To m, m.OFFSET

    _MemFree n

    _MemFree m

    LoadBMP1Bit = img

End Function







'******************************************************

' Funkce pro načtení 1-bit BMP a jeho vyhlazení

' Function to load a 1-bit BMP and apply smoothing (Gaussian blur)

'******************************************************

Function LoadAndSmoothBMP1Bit& (fileName As String)

    Dim img As Long

    img = LoadBMP1Bit(fileName) ' Načtení 1-bit BMP pomocí vlastní funkce

    ' Load 1-bit BMP using custom loader



    If img = 0 Then

        Print "Chyba při načítání BMP!" ' Error loading BMP!

        Print "Error loading BMP!"

        Exit Function

    End If



    Dim width As Long, height As Long

    width = _Width(img)

    height = _Height(img)



    ' Vytvoření nového obrázku pro vyhlazení

    ' Create a new image for the smoothed output

    Dim smoothedImg As Long

    smoothedImg = _NewImage(width, height, 32)



    ' Přístup k pixelovým datům

    ' Access pixel data of both images

    Dim m As _MEM, n As _MEM, jj As _MEM

    m = _MemImage(img)

    n = _MemImage(smoothedImg)



    ' Načtení pixelových dat do pole

    ' Copy pixels into an array for processing

    ReDim pixels(width * height - 1) As _Unsigned Long

    jj = _Mem(pixels())

    _MemCopy m, m.OFFSET, m.SIZE To jj, jj.OFFSET

    _MemFree jj



    ' Vyhlazení obrázku pomocí 3×3 Gaussova filtru

    ' Apply smoothing using a 3x3 Gaussian filter

    Dim x As Long, y As Long, i As Long, j As Long

    ReDim newPixels(width * height - 1) As _Unsigned Long



    ' Přibližný 3×3 Gaussův filtr

    ' Approximate 3x3 Gaussian filter weights

    Dim filter(2, 2) As Single

    filter(0, 0) = 1 / 16: filter(0, 1) = 2 / 16: filter(0, 2) = 1 / 16

    filter(1, 0) = 2 / 16: filter(1, 1) = 4 / 16: filter(1, 2) = 2 / 16

    filter(2, 0) = 1 / 16: filter(2, 1) = 2 / 16: filter(2, 2) = 1 / 16

    Dim rSum As Single, gSum As Single, bSum As Single

    Dim index As Long

    Dim pixelColor As _Unsigned Long

    Dim r As _Unsigned _Byte, g As _Unsigned _Byte, b As _Unsigned _Byte

    Dim newCol As _Unsigned Long



    ' Procházení obrazu (vynecháme okraje)

    ' Process the image excluding the borders

    For y = 1 To height - 2

        For x = 1 To width - 2

            rSum = 0: gSum = 0: bSum = 0

            ' Aplikace filtru 3×3

            ' Apply 3x3 filter

            For i = -1 To 1

                For j = -1 To 1

                    index = (y + i) * width + (x + j)

                    pixelColor = pixels(index)

                    r = _Red32(pixelColor)

                    g = _Green32(pixelColor)

                    b = _Blue32(pixelColor)

                    rSum = rSum + r * filter(i + 1, j + 1)

                    gSum = gSum + g * filter(i + 1, j + 1)

                    bSum = bSum + b * filter(i + 1, j + 1)

                Next j

            Next i

            ' Uložení vyhlazeného pixelu

            ' Save the smoothed pixel

            newCol = _RGB32(rSum, gSum, bSum)

            newPixels(y * width + x) = newCol

        Next x

    Next y



    ' Kopírování vyhlazených pixelů zpět do obrázku

    ' Copy the smoothed pixels back into the image

    Dim jjj As _MEM

    jjj = _Mem(newPixels())

    _MemCopy jjj, jjj.OFFSET, jjj.SIZE To n, n.OFFSET

    _MemFree jjj

    ' Uvolnění paměti

    ' Free memory

    _MemFree m

    _MemFree n

    _FreeImage img

    ' Výstup vyhlazeného obrázku

    ' Return the smoothed image

    LoadAndSmoothBMP1Bit = smoothedImg

End Function

Attached Files

Thumbnail(s)
       

I swore I had posted this before but I could not a record of it.
So, here is a small utility to monitor the memory usage:

Attached Files

  MEMUSAGE.ZIP (Size: 2.24 KB / Downloads: 19)

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.

' --- 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

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