Declare an .ico file - Printable Version

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$ = "appicon.ico" 'firefox ico file - show 6 images,





Total = LOADICO(file$, -1) 'TOTAL now contains number all frames in ICO file







_PrintMode _KeepBackground

Print "File contains"; Total; "frames."

For all = 1 To Total

    i& = LOADICO(file$, all)

    If i& < -1 Then _PutImage (X, 100), i&, 0

    X = X + _Width(i&)

    _FreeImage i&

Next





'try use 2nd ico image in this ico file use as your program icon:

ic& = LOADICO("appicon.ico", 2)

_Icon ic& 'show to program titlebar, it works correctly.







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