Author Topic: ICOns images loader for use in your programs  (Read 150 times)

Offline Petr

  • I am instructed.
ICOns images loader for use in your programs
« on: October 11, 2018, 12:30:46 PM »
This feature allows you to read / view / use all ICO file images. This is used because of the program, when has every user use other resolution. Therefore, you must use different sizes of icons for different resolutions (the digital zoom of the small icon is simply nasty). ICO format contains the same icon for different resolutions.

Code: [Select]
SCREEN _NEWIMAGE(800, 600, 32)



INPUT "input ICO file name: "; file$
IF INSTR(LCASE$(file$), ".ico") = 0 THEN file$ = file$ + ".ico"


Total = LOADICO(file$, -1) 'paramterer < 0 for return how much frames ICO file contains
PRINT "File contains"; Total; "frames."
SLEEP 2
nic = LOADICO(file$, 0) 'parameter zero for show all frames in ICO file

PRINT "Press key, program place icon frame 10 to 100, 100..."
SLEEP

'how place image 10 from file up.ico to screen:
CLS
image10 = LOADICO("up.ico", 10)
_PUTIMAGE (100, 100), image10








FUNCTION LOADICO& (file AS STRING, fram AS INTEGER)

    TYPE File_Head
        reserved AS INTEGER '0
        id_Type AS INTEGER '1
        id_Count AS INTEGER 'pocet ikon v souboru ICO
    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 'pocet bitovych rovin
        wBitCount AS _UNSIGNED INTEGER 'pocet bitu na pixel
        dwBytesInRes AS LONG 'delka obrazku v bytech vcetne palety
        dwImageOffset AS LONG 'zacatek ikony od zacatku souboru - tim se ridit!
    END TYPE



    TYPE Ico_Image
        ThisSize AS LONG '40
        width AS LONG
        height AS LONG
        biPlanes AS INTEGER '1
        BitCount AS INTEGER 'pocet bitu na pixel, tj 1, 4 , 8, 24
        Compression AS LONG '0 = BI_RGB, 1 = BI_RLE8, 2 = BI_RLE4
        SizeImage AS LONG 'velikost obrazu
        XPelsPerMeter AS LONG '0
        YPelsPerMeter AS LONG '0
        nic AS LONG '0
        taky_nic AS LONG '0
    END TYPE

    TYPE IcIm
        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
    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
    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
        Ico(al_fr).L = IH.dwBytesInRes
        Ico(al_fr).Offset = IH.dwImageOffset + 1
        IF IH.color_count = 0 THEN IHcolor_count = 256 ELSE IHcolor_count = IH.color_count
        Ico(al_fr).WP = IHcolor_count
    NEXT al_fr



    IF fram = 0 THEN vs = 1: ve = frames ELSE vs = fram: ve = fram
    FOR all = vs TO ve
        SEEK #ch, Ico(all).Offset


        IF Ico(all).BPP = 32 OR Ico(all).BPP = 24 THEN ' nejprve otestuju pritomnost PNG pokud je hloubka 32 bit:
            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

        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


        icon& = _NEWIMAGE(Ico(all).W, Ico(all).H, depth)
        _DEST icon&

        SELECT CASE Ico(all).BPP
            CASE 1
                PalLenght = 1
            CASE 4
                PalLenght = 15
            CASE 8
                PalLenght = 255
            CASE 0, 32, 24
                GOTO _______NoPalete
        END SELECT

        REDIM pal AS _UNSIGNED LONG
        FOR palete = 0 TO PalLenght
            GET #ch, , pal
            _PALETTECOLOR palete, pal, icon&
        NEXT palete
        _______NoPalete:

        SELECT CASE Ico(all).BPP

            CASE 1
                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
                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 = 0
                drawY = Ico(all).H
                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

                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
                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)
                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
                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 0
        IF fram = 0 THEN
            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 0: 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 DECtoBIN$ = DECtoBIN$ + "1" ELSE DECtoBIN$ = DECtoBIN$ + "0"
    NEXT rj
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
        BINtoDEC = BINtoDEC + (c * 2 ^ Sj)
    NEXT Si
END FUNCTION

FUNCTION extract_png& (ch)
    start$ = CHR$(137) + CHR$(80) + CHR$(78) + CHR$(71) + CHR$(13) + CHR$(10) + CHR$(26) + CHR$(10)
    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)
    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


Attached image show, what is possible with this (and more subprograms) to do.
« Last Edit: October 11, 2018, 12:50:36 PM by Petr »

Offline FellippeHeitor

  • QB64 Developer
  • LET IT = BE
    • QB64.org
Re: ICOns images loader for use in your programs
« Reply #1 on: October 11, 2018, 12:40:07 PM »
Good job, Petr. I wrote a simple icon viewer function for InForm, but it doesn't go as far as yours goes, extracting all possible images. Kudos.

Just a suggestion:
Code: [Select]
'IF NOT INSTR(file$, LCASE$(".ico")) THEN file$ = file$ + ".ico"
IF INSTR(LCASE$(file$), ".ico") = 0 THEN file$ = file$ + ".ico"

The original line was not going to work as you expected it to.
« Last Edit: October 11, 2018, 12:55:11 PM by FellippeHeitor »

Offline Petr

  • I am instructed.
Re: ICOns images loader for use in your programs
« Reply #2 on: October 11, 2018, 12:59:32 PM »
Thank you, Fellippe for warning. Fixed. ÏCO files cotains this images can be downloaded from http://www.iconarchive.com/, When I read the definition of SVG files, I remembered Steve and his library...  :-D

Offline FellippeHeitor

  • QB64 Developer
  • LET IT = BE
    • QB64.org
Re: ICOns images loader for use in your programs
« Reply #3 on: October 11, 2018, 01:05:47 PM »
I love iconarchive.com, it's where InForm's icon comes from.

About SVG files, here's my simple (and *very* limited) SVG reader: https://github.com/FellippeHeitor/Snippets/blob/master/svg.bas (won't likely render any of those fancy icons).
« Last Edit: October 11, 2018, 01:09:12 PM by FellippeHeitor »

Offline Petr

  • I am instructed.
Re: ICOns images loader for use in your programs
« Reply #4 on: October 11, 2018, 01:16:51 PM »
That's absolutely amazing, thank you for the link, Fellippe. I'll immediately look at the source to find a solution to the Bazier curves. That's very good for me.