'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.
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
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
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
I found a nice subroutine to return a .bmp file converted from a .ico file:
Code: (Select All)
Function Icon2BMP% (filein As String, fileout As String, index As Integer)
Dim byte As _Unsigned _Byte, word As Integer, dword As Long
Dim wide As Long, high As Long, BM As Integer, bpp As Integer
rf = FreeFile
If LCase$(Right$(filein, 4)) <> ".ico" Then 'check file extension is ICO only
Exit Function
End If
Open filein For Binary Access Read As rf
Get rf, , word
Get rf, , word: icon = word
Get rf, , word: count = word
If icon <> 1 Or count = 0 Then Close rf: Exit Function
If index > 0 And index <= count Then entry = 16 * (index - 1) Else entry = 16 * (count - 1)
Seek rf, 1 + 6 + entry 'start of indexed Entry header
Get rf, , byte: wide = byte ' use this unsigned for images over 127
Get rf, , byte: high = byte ' use this unsigned because it isn't doubled
Get rf, , word 'number of 4 BPP colors(256 & 32 = 0) & reserved bytes
Get rf, , dword '2 hot spots both normally 0 in icons, used for cursors
Get rf, , dword: size = dword 'this could be used, doesn't seem to matter
Get rf, , dword: offset = dword 'find where the specific index BMP header is
Seek rf, 1 + offset + 14 'only read the BPP in BMP header
Get rf, , word: bpp = word
If bpp = 0 Then Close rf: Exit Function
If bpp <= 24 Then pixelbytes = bpp / 8 Else pixelbytes = 3
If bpp > 1 And bpp <= 8 Then palettebytes = 4 * (2 ^ bpp) Else palettebytes = 0
datasize& = (wide * high * pixelbytes) + palettebytes 'no padder should be necessary
filesize& = datasize& + 14 + 40 ' data and palette + header
bmpoffset& = palettebytes + 54 ' data offset from start of bitmap
readbytes& = datasize& + 28 ' (40 - 12) bytes left to read in BMP header and XOR mask only
BM = CVI("BM") 'this will create "BM" in file like MKI$ would
wf = FreeFile
Open fileout For Binary As wf
Put wf, , BM
Put wf, , filesize&
dword = 0
Put wf, , dword
Put wf, , bmpoffset& 'byte location of end of palette or BMP header
dword = 40
Put wf, , dword ' start of 40 byte BMP header
Put wf, , wide
Put wf, , high
Seek rf, 1 + offset + 12 ' after 12 bytes start copy of BMP header starting at planes
dat$ = String$(readbytes&, 0) 'create string to hold remaining bytes needed w/o AND mask data
Get rf, , dat$ ' copy lower header, palette(if used) and XOR mask
Put wf, , dat$ ' put all of the string data in the bitmap all at once
Close rf, wf
Icon2BMP = count ' return the number of icons available in the icon file
End Function
(02-26-2024, 05:02 AM)eoredson Wrote: I found a nice subroutine to return a .bmp file converted from a .ico file:
Code: (Select All)
Function Icon2BMP% (filein As String, fileout As String, index As Integer)
Dim byte As _Unsigned _Byte, word As Integer, dword As Long
Dim wide As Long, high As Long, BM As Integer, bpp As Integer
rf = FreeFile
If LCase$(Right$(filein, 4)) <> ".ico" Then 'check file extension is ICO only
Exit Function
End If
Open filein For Binary Access Read As rf
Get rf, , word
Get rf, , word: icon = word
Get rf, , word: count = word
If icon <> 1 Or count = 0 Then Close rf: Exit Function
If index > 0 And index <= count Then entry = 16 * (index - 1) Else entry = 16 * (count - 1)
Seek rf, 1 + 6 + entry 'start of indexed Entry header
Get rf, , byte: wide = byte ' use this unsigned for images over 127
Get rf, , byte: high = byte ' use this unsigned because it isn't doubled
Get rf, , word 'number of 4 BPP colors(256 & 32 = 0) & reserved bytes
Get rf, , dword '2 hot spots both normally 0 in icons, used for cursors
Get rf, , dword: size = dword 'this could be used, doesn't seem to matter
Get rf, , dword: offset = dword 'find where the specific index BMP header is
Seek rf, 1 + offset + 14 'only read the BPP in BMP header
Get rf, , word: bpp = word
If bpp = 0 Then Close rf: Exit Function
If bpp <= 24 Then pixelbytes = bpp / 8 Else pixelbytes = 3
If bpp > 1 And bpp <= 8 Then palettebytes = 4 * (2 ^ bpp) Else palettebytes = 0
datasize& = (wide * high * pixelbytes) + palettebytes 'no padder should be necessary
filesize& = datasize& + 14 + 40 ' data and palette + header
bmpoffset& = palettebytes + 54 ' data offset from start of bitmap
readbytes& = datasize& + 28 ' (40 - 12) bytes left to read in BMP header and XOR mask only
BM = CVI("BM") 'this will create "BM" in file like MKI$ would
wf = FreeFile
Open fileout For Binary As wf
Put wf, , BM
Put wf, , filesize&
dword = 0
Put wf, , dword
Put wf, , bmpoffset& 'byte location of end of palette or BMP header
dword = 40
Put wf, , dword ' start of 40 byte BMP header
Put wf, , wide
Put wf, , high
Seek rf, 1 + offset + 12 ' after 12 bytes start copy of BMP header starting at planes
dat$ = String$(readbytes&, 0) 'create string to hold remaining bytes needed w/o AND mask data
Get rf, , dat$ ' copy lower header, palette(if used) and XOR mask
Put wf, , dat$ ' put all of the string data in the bitmap all at once
Close rf, wf
Icon2BMP = count ' return the number of icons available in the icon file
End Function
Might be handy! but seems more like a "Utility" routine than a "Help Me" barely related to thread subject that is old anyway. Paint can't do this?
![[Image: SIC64.png]](https://i.ibb.co/pJ5Cvtt/SIC64.png)
![[Image: ico-is-there.png]](https://i.ibb.co/8dG0sZ4/ico-is-there.png)
