03-29-2023, 09:46 AM
(03-28-2023, 10:06 PM)eoredson Wrote: 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 Functionused free ico file is attached in zip format
Program set icon
![[Image: ico-is-there.png]](https://i.ibb.co/8dG0sZ4/ico-is-there.png)
: