Declare an .ico file

[eoredson]

@TempodiBasic:

and so it seems doing QB64pe...
so I miss the meaning of your message.
Please can say me it in other words?

I am not trying to do anything fancy like loading icons or displaying them.

All I want is the icon on the top-left of the titlebar.

Erik. This is my icon..

[Petr]

Sorry, got the wrong link:
https://qb64phoenix.com/qb64wiki/index.php/ICON
NOTE: Icon files are not supported with _LOADIMAGE and an error will occur.

So again: Use my program LoadIco. Here is another example of how to get an icon (ico file) in the upper left corner of the program window:

ICO File free downloaded from https://icon-icons.com/download/111465/ICO/48/

USE LOADICO FOR SET PROGRAM ICON

Code: (Select All)

'Petr Preclik presents:
'LOADICO function. Use ico files as icons in your programs! Use it as:  handle = LOADICON (ico_file_name$, number of frame in this ICO file)
'                                                   For list all images in ICO file set second parameter to zero (call it in 32 bit screen)
'                                                                  For returning how much frames ICO contains, set second parameter as < 0.

_Title "ICO Loader"
Screen _NewImage(1024, 600, 32)
Cls , _RGB32(25, 0, 12)

file$ = "12099handshake_111465.ico"


Ico = LOADICO(file$, 1)
_Icon Ico






Function LOADICO& (file As String, fram As Integer)
    'file identity header
    PD = _Dest
    Type File_Head
        reserved As Integer '0
        id_Type As Integer '1
        id_Count As Integer 'number of frames in file
    End Type

    Type ICO_Head
        bWidth As _Unsigned _Byte
        bHeight As _Unsigned _Byte
        color_count As _Unsigned _Byte '0 = >256 colors
        bReserved As _Unsigned _Byte '0
        wPlanes As _Unsigned Integer 'number of bit layers
        wBitCount As _Unsigned Integer 'bites per pixel
        dwBytesInRes As Long 'image lenght included palette
        dwImageOffset As Long 'icon begin from file begin (driving record)
    End Type



    Type Ico_Image
        ThisSize As Long '40
        width As Long
        height As Long
        biPlanes As Integer '1
        BitCount As Integer 'bites per pixel, tj 1, 4 , 8, 24
        Compression As Long '0 = BI_RGB, 1 = BI_RLE8, 2 = BI_RLE4
        SizeImage As Long 'image size
        XPelsPerMeter As Long '0
        YPelsPerMeter As Long '0
        nic As Long '0        'nothing :)
        taky_nic As Long '0   'also nothing :)  i have none informations and none sources - for what is this!
    End Type

    Type IcIm 'help array (maybe? - this is wroted long time ago... :-/ )
        W As Integer
        H As Integer
        colors As _Unsigned _Byte
        BPP As _Unsigned _Byte
        L As Long
        Offset As Long
        WP As _Unsigned Integer
    End Type

    Dim FH As File_Head, IH As ICO_Head, II As Ico_Image
    ch = FreeFile

    If _FileExists(file$) Then Open file$ For Binary As #ch Else Print "ICO loader error: file "; file$; " not exist.": Sleep 2: System
    Get #ch, , FH
    If FH.reserved = 0 And FH.id_Type = 1 Then Else Print "unknown format!": System
    frames = FH.id_Count 'frames number (total frames) in file
    If fram < 0 Then LOADICO& = frames: Exit Function '                                                                                                        -1 is for returning number frames in file
    If fram > frames Then Print "This file contains not so much images. File "; file$; " contains "; frames; "frames. Can not using frame"; fram: Sleep 2: Exit Function
    ' PRINT "Frames in file: "; frames
    ReDim Ico(frames) As IcIm
    For al_fr = 1 To frames
        Get #ch, , IH
        Ico(al_fr).W = IH.bWidth
        Ico(al_fr).H = IH.bHeight
        Ico(al_fr).colors = IH.color_count '0 = >256 colors
        Ico(al_fr).BPP = IH.wBitCount 'bites per pixel
        Ico(al_fr).L = IH.dwBytesInRes 'image lenght included palette
        Ico(al_fr).Offset = IH.dwImageOffset + 1 'icon record byte start position from file begin
        If IH.color_count = 0 Then IHcolor_count = 256 Else IHcolor_count = IH.color_count
        Ico(al_fr).WP = IHcolor_count
    Next al_fr
    'vsechny hlavy ke vsem snimkum jsou nacteny. Tato hlava je ridici pro kazdy snimek.
    'all heads for all frames are ready. This is head for every head

    If fram = 0 Then vs = 1: ve = frames Else vs = fram: ve = fram
    For all = vs To ve
        Seek #ch, Ico(all).Offset 'posun na spravnou pozici       skip to correct position

        If Ico(all).BPP = 32 Then ' nejprve otestuju pritomnost PNG pokud je hloubka 32 bit: 'first testing, if PNG is contained in file, when bites per pixel is 32
            current_position = Seek(ch)
            Dim start_test As String * 8
            '            DIM end_test AS STRING * 12
            start$ = Chr$(137) + Chr$(80) + Chr$(78) + Chr$(71) + Chr$(13) + Chr$(10) + Chr$(26) + Chr$(10)
            Get #ch, , start_test$
            If start_test$ = start$ Then
                Ico(all).BPP = 32
                Ico(all).W = 256
                Ico(all).H = 256
                icon& = _CopyImage(extract_png&(ch), 32): GoTo ______skip
            Else
                Seek #ch, current_position
            End If
        End If
        Get #ch, , II '            nactu hlavu obrazku. Tato hlava je navic a nepouziva se, aspon mysim....  ' really i dont know for what is this, just some records

        If Ico(all).BPP > 0 And Ico(all).BPP <= 8 Then depth = 256 Else depth = 32
        If Ico(all).W = 0 Then Ico(all).W = 256
        If Ico(all).H = 0 Then Ico(all).H = 256

        '   PRINT Ico(all).W, Ico(all).H, depth
        icon& = _NewImage(Ico(all).W, Ico(all).H, depth)
        _Dest icon&

        Select Case Ico(all).BPP '   za havou bitmapy nasleduje paleta   After bitmap header is palette
            Case 1
                PalLenght = 1
            Case 4
                PalLenght = 15 'ok pro 4 barvy  OK for 4 colors
            Case 8
                PalLenght = 255
            Case 0, 32
                GoTo _______noPalete
        End Select

        ReDim pal As _Unsigned Long 'vypoctem potvrzeno long   LONG confirmed :)
        For palete = 0 To PalLenght
            Get #ch, , pal
            _PaletteColor palete, pal, icon&
        Next palete
        _______noPalete:

        Select Case Ico(all).BPP 'podle bitove hloubky probehne vykresleni     drawing starts by bit depth

            Case 1 ' testovano na jednom jedinem pripade...      this is tested just on ONE file
                ReDim bwi As String, valuee As _Unsigned _Byte
                For draw1 = 1 To Ico(all).W * Ico(all).H
                    Get #ch, , valuee
                    bwi = bwi + DECtoBIN$(valuee)
                Next

                drawX = 0
                drawY = Ico(all).H
                For DrawXOR = 1 To Ico(all).W * Ico(all).H

                    If (Mid$(bwi$, DrawXOR, 1)) = "1" Then PSet (drawX, drawY)
                    drawX = drawX + 1: If drawX >= Ico(all).W And Ico(all).H Mod 4 = 0 Then drawX = 0: drawY = drawY - 1
                Next

            Case 4 '                                                   pro soubory o jednom snimku naprosto v poradku (neni podpora PNG ale to asi v 16ti barvach nebude potreba)
                '                                                      for files contins one frame is this all right (is not PNG support in 16 colors, i think this is not need)
                Dim R4 As _Unsigned _Byte
                binary$ = ""

                For READ_XOR_DATA = 1 To (Ico(all).W * Ico(all).H) / 2
                    Get #ch, , R4
                    binary$ = binary$ + DECtoBIN$(R4)
                Next READ_XOR_DATA

                Dim colors4(Len(binary$)) As _Byte
                calc_color = 0


                For calc_colors = 1 To Len(binary$) Step 4
                    colors4(calc_color) = BINtoDEC(Mid$(binary$, calc_colors, 4))
                    calc_color = calc_color + 1
                Next calc_colors

                binary$ = ""

                clc = 0

                drawX = -1
                drawY = Ico(all).H - 1
                For DrawXOR = 0 To Ico(all).W * Ico(all).H
                    drawX = drawX + 1: If drawX >= Ico(all).W And Ico(all).H Mod 8 = 0 Then drawX = 0: drawY = drawY - 1
                    If drawX < Ico(all).W Then PSet (drawX, drawY), colors4(clc): clc = clc + 1
                Next



                'Pak je AND maska (sirka * vyska) / 8 a nakonec data obrazku
                'Then is AND mask (widht * height) / 8 and in end are image data
                Erase colors4: binary$ = ""
                AndMaskLen = (Ico(all).H * Ico(all).W) / 8

                For AM = 1 To AndMaskLen
                    Get #ch, , R4
                    binary$ = binary$ + DECtoBIN$(R4)
                Next AM


                clc = 0
                For DrawAND = 0 To Ico(all).W * Ico(all).H
                    drawX = drawX + 1: If drawX >= Ico(all).W And Ico(all).H Mod 8 = 0 Then drawX = 0: drawY = drawY - 1
                    If drawX <= Ico(all).W And Mid$(binary$, clc, 1) = "1" Then
                        _Source icon&
                        cur = Point(drawX, drawY)
                        PSet (drawX, drawY), 255 And cur: clc = clc + 1
                    End If
                Next
                _Source 0

            Case 8
                ReDim colors8(Ico(all).H * Ico(all).W) As _Unsigned _Byte
                For calc_colors = 1 To Ico(all).H * Ico(all).W
                    Get #ch, , colors8(calc_colors)
                Next calc_colors

                binary$ = ""
                AndMaskLen = (Ico(all).H * Ico(all).W) / 8 'predelavano
                ReDim r5 As _Unsigned _Byte
                For AM = 1 To AndMaskLen
                    Get #ch, , r5
                    binary$ = binary$ + DECtoBIN$(r5)
                Next AM

                clc = 0
                For draw_itY = 1 To Ico(all).H
                    For draw_itX = 0 To Ico(all).W - 1
                        clc = clc + 1
                        _Source icon&
                        cur = Point(draw_itX + 1, draw_itY)
                        PSet (draw_itX, Ico(all).H - draw_itY), colors8(clc) ' XOR cur
                Next: Next

                drawY = Ico(all).H - 1
                clc = 0
                For DrawAND = 1 To Ico(all).W * Ico(all).H
                    drawX = drawX + 1: If drawX >= Ico(all).W And Ico(all).H Mod 4 = 0 Then drawX = 0: drawY = drawY - 1
                    clrr = Point(drawX, drawY)
                    clc = clc + 1
                    If Mid$(binary$, clc, 1) = "1" Then PSet (drawX, drawY), 255 And clrr

                Next
                _Source 0


            Case 0, 32 'overeno, v tomto pripade se opravdu ctou 4 byty 'confirmed, in this case are really 4 bytes read
                ReDim cache(1 To Ico(all).W, 1 To Ico(all).H) As _Unsigned Long

                For draw_itY = 1 To Ico(all).H
                    For draw_itX = 1 To Ico(all).W
                        Get #ch, , cache(draw_itX, draw_itY)
                Next: Next

                For draw_itY = 1 To Ico(all).H
                    For draw_itX = 1 To Ico(all).W
                        PSet (draw_itX - 1, Ico(all).H - draw_itY), cache(draw_itX, draw_itY)
                Next: Next
                Erase cache
        End Select

        ______skip:
        _Dest PD
        If fram = 0 Then 'function paramter 0 as fram is for view all images in ico file (my loop muss be in 32 bit graphic mode)
            'vypis pokud bude paramter nula
            If _PixelSize(_Dest) < 4 Then Print "LOADICO parameter is set as 0. This option is for view all frames in ICO and muss be used with 32 bit screen.": Sleep 2: Exit Function
            ______resetview:
            If listed = 0 Then listed = 1: Cls: _PrintString (300, 20), "    Image nr.   Width   Height    BPP    Color count": row = 40
            If _Height - (row + 10) < 256 Then _PrintString (50, row + 100), "Press key for view next...": Sleep: Cls: listed = 0: GoTo ______resetview
            _PutImage (50, row), icon&, 0
            _FreeImage icon&
            row = row + Ico(all).H + 10
            info$ = "  " + Str$(all) + "      " + Str$(Ico(all).W) + "      " + Str$(Ico(all).H) + "    " + Str$(Ico(all).BPP) + "         " + Str$(Ico(all).WP)
            _PrintString (350, row - (Ico(all).H + 10 / 2)), info$
        Else
            If all = fram Then LOADICO& = icon&: _Dest PD: Exit Function Else _FreeImage icon&
        End If
    Next all
End Function



Function DECtoBIN$ (vstup)
    For rj = 7 To 0 Step -1
        If vstup And 2 ^ rj Then DECtoBI$ = DECtoBI$ + "1" Else DECtoBI$ = DECtoBI$ + "0"
    Next rj
    DECtoBIN$ = DECtoBI$
End Function

Function BINtoDEC (b As String)
    For Si = 1 To Len(b)
        e$ = Mid$(b$, Si, 1)
        c = Val(e$) '
        Sj = Len(b) - Si
        BINtoDE = BINtoDE + (c * 2 ^ Sj)
    Next Si
    BINtoDEC = BINtoDE
End Function

Function extract_png& (ch) 'Warning. This function can be very easy used for extraction PNG files from all (also binary) files!
    'BEEP
    start$ = Chr$(137) + Chr$(80) + Chr$(78) + Chr$(71) + Chr$(13) + Chr$(10) + Chr$(26) + Chr$(10) 'PNG start ID string
    eend$ = Chr$(0) + Chr$(0) + Chr$(0) + Chr$(0) + Chr$(73) + Chr$(69) + Chr$(78) + Chr$(68) + Chr$(174) + Chr$(66) + Chr$(96) + Chr$(130) 'PNG end ID string
    Seek #ch, Seek(ch) - 8
    Z = Seek(ch)
    Dim scan As String * 12
    Do
        Get #ch, , scan$
        If scan$ = eend$ Then Exit Do
        Seek #ch, Seek(ch) - 11
    Loop
    K = Seek(ch)
    png$ = Space$(K - Z)
    Seek #ch, Z
    Get #ch, , png$
    swp = FreeFile
    Open "---png_extr_" For Output As #swp
    Close #swp: Open "---png_extr_" For Binary As #swp
    Put #swp, , png$
    Close #swp
    extract_png& = _LoadImage("---png_extr_", 32)
    Kill "---png_extr_"
    png$ = ""
End Function

used free ico file is attached in zip format

Program set icon


:

[mnrvovrfc]

Will need a stronger solution away from Windows. I tested on EndeavourOS (based on Arch Linux) but should also check it out on Debian clone.

[eoredson]

@Petr:

Nice code but too complex and beyond the scope of what I am doing.

I am going with the following:

Code: (Select All)

i& = _LoadImage("SIC64.BMP", 32)
If i& < -1 Then
    _Icon i&
    _FreeImage i&
End If
Do
    If Len(InKey$) Then End
Loop

[eoredson]

Alright. I broke down and added y0ur Icon utility mostly to cover my bases:

Code: (Select All)

' set title icon
Sub DisplayIcon
    Icon$ = UCase$(TitleBarIcon$)
    If Right$(Icon$, 4) = ".ICO" Then
        If _FileExists(Icon$) Then
            Icon& = LOADICON&(Icon$, 1)
            If Icon& < -1 Then
                _Icon Icon&
                _FreeImage Icon&
            End If
        End If
    Else
        Icon& = _LoadImage(TitleBarIcon$, 32)
        If Icon& < -1 Then
            _Icon Icon&
            _FreeImage Icon&
        End If
    End If
End Sub