Code: Select all
;make a ico pack out of a image image should be square 32 bit depth
;Idle ChrisR
EnableExplicit
Structure ICONDIR
res.u
type.u
num.u
EndStructure
Structure ICONDIRECTORYENTRY
width.a
height.a
numcolors.a
res.a
colorplanes.u
bitsperpixel.u
size.l
offset.l
EndStructure
Structure ICONData
header.ICONDIR
icons.ICONDIRECTORYENTRY[15]
EndStructure
Structure bufs
*buffer[15]
EndStructure
UsePNGImageEncoder()
UsePNGImageDecoder()
; https://learn.microsoft.com/en-us/windows/apps/design/style/iconography/app-icon-construction
; Apps should have, at the bare minimum: 16x16, 24x24, 32x32, 48x48, And 256x256.
; This covers the most common icon sizes, And by providing a 256px icon, ensures Windows should only ever scale your icon down, never up.
Procedure CreateIconFile(file.s,image,xsize.s="16x24x32x48x256")
Protected ico.ICONData
Protected buf.bufs
Protected timg,fn,offset,a,b,countsize=CountString(xsize,"x")+1
If countsize > 15 : countsize=15 : EndIf
Dim sz(countsize-1)
Repeat
sz(a) = Val(StringField(xsize, a+1, "x"))
a+1
Until a = countsize
offset = SizeOf(ICONData)
ico\header\num=countsize
ico\header\type=1
offset = SizeOf(ICONData)
If file <> ""
fn = CreateFile(#PB_Any,file)
If fn
a = 0
Repeat
timg = CopyImage(image,#PB_Any)
If timg
If ResizeImage(timg,sz(a),sz(a),#PB_Image_Smooth)
buf\buffer[a] = EncodeImage(timg, #PB_ImagePlugin_PNG, 0, 32)
EndIf
Else
For b = 0 To a
If buf\buffer[a]
FreeMemory(buf\buffer[a])
EndIf
Next
CloseFile(fn)
ProcedureReturn 0
EndIf
FreeImage(timg)
ico\icons[a]\width = sz(a)
ico\icons[a]\height = sz(a)
ico\icons[a]\colorplanes = 1
ico\icons[a]\bitsperpixel = 32
ico\icons[a]\size = MemorySize(buf\buffer[a])
ico\icons[a]\offset = offset
offset + ico\icons[a]\size
a+1
Until a = countsize
a=0
WriteData(fn,@ico,SizeOf(ICONData))
Repeat
WriteData(fn,Buf\buffer[a],ico\icons[a]\size)
FreeMemory(Buf\buffer[a])
a+1
Until a = countsize
CloseFile(fn)
ProcedureReturn 1
EndIf
EndIf
EndProcedure
Define file$, Tcolor.l
Procedure TransparentCallback(x, y, sourcecolor.l, targetcolor.l)
Shared Tcolor
If Red(sourcecolor) = Red(Tcolor) And Green(sourcecolor) = Green(Tcolor) And Blue(sourcecolor) = Blue(Tcolor)
targetcolor = RGBA(0,0,0,0)
Else
targetcolor = sourcecolor
EndIf
ProcedureReturn targetcolor
EndProcedure
; Example1 OpenFileRequester png Image
; file$ = OpenFileRequester("Choose icon base image", GetUserDirectory(#PB_Directory_Pictures), "png Image (*.png)|*.png", 0)
; If file$
; LoadImage(1,file$)
; file$ = GetPathPart(file$) + GetFilePart(file$, #PB_FileSystem_NoExtension) + ".ico"
; End CreateIconFile(file$,1)
; Else
; End
; EndIf
; Example2 test Image
; If CreateImage(1,512,512,32,#PB_Image_Transparent)
; If StartVectorDrawing(ImageVectorOutput(1))
; VectorSourceColor(RGBA(255, 0, 0, 255))
; AddPathCircle(512 / 2, 512 / 2, 512 / 3 )
; FillPath()
; StopVectorDrawing()
; EndIf
; EndIf
; file$ = "e:\test.ico"
; End CreateIconFile(file$,1)
; Example3 Transparent geebee2.bmp Image
If LoadImage(0, #PB_Compiler_Home + "examples\sources\data\geebee2.bmp")
If StartDrawing(ImageOutput(0))
Tcolor = Point(0,0)
StopDrawing()
CreateImage(1,ImageWidth(0),ImageHeight(0),32,#PB_Image_Transparent)
If StartDrawing(ImageOutput(1))
DrawingMode(#PB_2DDrawing_CustomFilter)
CustomFilterCallback(@TransparentCallback())
DrawImage(ImageID(0),0,0)
StopDrawing()
EndIf
FreeImage(0)
EndIf
EndIf
file$ = "e:\geebee2.ico"
CreateIconFile(file$,1)
file$ = "e:\geebee2All.ico"
CreateIconFile(file$,1,"16x24x32x48x64x96x128x256")
I did try to add them but failed, because you're resizing with "sz << 1" and I can't work around that. 
