Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
 
FAQFAQ   SuchenSuchen   MitgliederlisteMitgliederliste   BenutzergruppenBenutzergruppen  RegistrierenRegistrieren
ProfilProfil   Einloggen, um private Nachrichten zu lesenEinloggen, um private Nachrichten zu lesen   LoginLogin
Zur Begleitseite des Forums / Chat / Impressum
Aktueller Forenpartner:

HICON to FB.IMAGE mit Alpha-Kanal und beliebiger Bitrate

 
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Windows-spezifische Fragen
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
noop



Anmeldungsdatum: 04.05.2005
Beiträge: 259

BeitragVerfasst am: 23.03.2016, 18:17    Titel: HICON to FB.IMAGE mit Alpha-Kanal und beliebiger Bitrate Antworten mit Zitat

Hallo,

ich hatte bereits im englischen Forum ein Thema eröffnet, http://www.freebasic.net/forum/viewtopic.php?f=6&t=24507, und hier ein Thema mit ähnlichem Inhalt gesehen: https://forum.qbasic.at/viewtopic.php?t=8718.

Mein Problem ist, dass bei Icons mit einer Bitrate unter 32 der Alpha-Kanal nicht gefüllt wird. Dadurch wird beim Darstellen mit put nichts angezeigt.
Dazu erstmal modifizierter Code aus https://forum.qbasic.at/viewtopic.php?t=8718:
Code:
#include    Once "windows.bi"
#include    Once "win\shellapi.bi"
#include    Once "fbgfx.bi"

#define getPixelAddress(img,row,col) cast(any ptr,img) + _
    sizeof(FB.IMAGE) + img->pitch * row + img->bpp * col

screenres 320,240,32
color(0,RGBA(225,225,225,225))
cls

function getfbimage(byval filename as string) as FB.Image ptr
    dim as FB.Image ptr mIcon = imageCreate( 32 , 32 )
   
    '' Fenster handle
    dim as HWND     mHwnd
    ScreenControl( FB.GET_WINDOW_HANDLE, cast(integer,mHwnd) )
   
    dim as HICON hLargeIcon
    extractIconEx(filename, 0, @hLargeIcon, 0, 1)
   
    '' BitMap erstellen
    dim as HDC      mHdc    = GetDC(mHwnd)
    dim as HDC      hdcComp = CreateCompatibleDC(mHdc)
    dim as HBITMAP  bitmap  = CreateCompatibleBitmap( mHdc , 32 , 32 )
   
    SelectObject( hdcComp , bitmap )
   
    dim as BITMAPINFO bmi
    With bmi.bmiHeader
      .biSize = SizeOf(BITMAPINFOHEADER)
      .biWidth =  32
      .biHeight = -32
      .biPlanes = 1
      .biCompression = BI_RGB
      .biBitCount = 32
    End With
   
    '' Icon in die Bmp zeichnen
    DrawIconEx( hdcComp, 0, 0, hLargeIcon, 32, 32, 0, NULL, DI_NORMAL )
   
    '' fbImage erstellen/befüllen
    GetDIBits( hdcComp, bitmap, 0, 32, getPixelAddress(mIcon,0,0), @bmi, DIB_RGB_COLORS)
   
    ReleaseDC( mHwnd , mHdc )
    DestroyIcon(hLargeIcon)
    DeleteDC(hdcComp)
    DeleteObject(bitmap)
    return mIcon
end function

dim as FB.Image ptr icon1 = getfbimage($"C:\Windows\notepad.exe")
dim as FB.Image ptr icon2 = getfbimage($"C:\WINDOWS\System32\shell32.dll")
if icon1 then
    put (50,50),icon1,alpha
    put (50,90),icon1,pset
    imageDestroy(icon1)
end if
if icon2 then
    put (90,50),icon2,alpha
    put (90,90),icon2,pset
    imageDestroy(icon2)
end if

getKey


Daher habe ich in http://www.freebasic.net/forum/viewtopic.php?f=6&t=24507 eine Alternative beschrieben, welche jedoch 1. hässlich und 2. in Ausnahmefällen nicht funktioniert. Dazu überprüfe ich den Alpha-Kanal der geladenen Daten. Ist dort alles Null, so nehme ich an, dass das Icon mit weniger als 32 bit kodiert ist. Ich schaue mir dann die Bitmaske des Icons an und ermittle daran die Transparenz. Jedoch ist es legitim, wenn ein Icon 32-bit kodiert ist und nicht die Bitmaske verwendet (die Dropbox executable hat solch ein Icon). Somit erkenne ich keine voll-transparenten 32-bit-Icons, die die Bitmaske nicht verwenden.
Code:
' This sample script loads an icon via extractIconEx() from an .ico-file and
' then converts it to an FB.Image and displays it.
'
' See the function description for a caveat in the implementation.
'

#include once "fbgfx.bi"
#include once "windows.bi"
#include once "win/shellapi.bi"
#include "vbcompat.bi"

#define getPixelAddress(img,row,col) cast(any ptr,img) + _
    sizeof(FB.IMAGE) + img->pitch * row + img->bpp * col
   
function hIcon2fbImage(byval hIcon as HICON) as FB.Image ptr
    ' This function converts an HICON to an FB.Image.
    '
    ' Important:
    '    1) This implementation does not account for black&white icons.
    '    2) If an icon is fully transparent, stored in 32-bit and didn't set
    '       the transparency-mask, then you will get a fully opaque icon
    '       with whatever background colour was used.
    '          The implementation is hacky. I couldn't find a way to determine
    '          if the bitrate of the originally loaded icon is 32-bit or lower.
    '          If it is lower than 32-bit, then Windows still responds with
    '          "it's 32-bit". Unfortunately Windows doesn't fill the alpha
    '          channel, so that when displaying it using alpha channels, the
    '          icon will be fully transparent.
    '          I couldn't find a way to reliably determine, if an icon is
    '          32-bit or lower. The following occurs:
    '          a) The icon is 32-bit and has some alpha values which are not 0
    '             and also not 255 (i.e. neither fully transparent nor fully
    '             opaque). In that case the script finds these pixels and knows
    '             that the icon was originally in 32-bit.
    '          b) The icon is 32-bit but is completely transparent (all alpha
    '             values are zero). Furthermore the transparency bitmask was
    '             not set (i.e. it's all zero). Due to all-zero alpha values
    '             the script does not know that it's a 32-bit image. It will
    '             then look at the bitmask. If the bitmask says "this pixel is
    '             opaque" (i.e. the the pixel has a value of zero in the
    '             bitmask), then the script will assume that the image has a
    '             bitrate lower than 32. Since the bitmask is fully zero, it
    '             will, erroneously, set the image as fully opaque.
    '          c) The icon has a bitrate lower than 32-bit. Then all alpha
    '             values will be zero. The script will then use the bitmask to
    '             determine if a pixel is supposed to be fully opaque or fully
    '             transparent.
    '    3) This implementation assumes that "standard" icons  are used, i.e.,
    '       icons with a width that is a multiple of 16. Otherwise memory
    '       alignment requires another step (using a temporary buffer).
    '
   
    dim as ICONINFO icoInfo
    dim as BITMAP bitmask
    if getIconInfo(hIcon, @icoInfo) = FALSE then return 0
    if getObject(icoInfo.hbmMask, sizeof(BITMAP), @bitmask) = FALSE then
        deleteObject(icoInfo.hbmMask)
        deleteObject(icoInfo.hbmColor)
        return 0
    end if
   
    dim as integer w,h
    w = bitmask.bmWidth
    h = bitmask.bmHeight
   
    dim as BITMAPINFO bmi
    dim as BITMAPINFOHEADER bmh
    with bmh
        .biSize = sizeof(BITMAPINFOHEADER)
        .biWidth = w
        .biHeight = -h
        .biPlanes = 1
        .biCompression = BI_RGB
        .biBitCount = 32
        .biSizeImage = w*h*4
    end with
    bmi.bmiHeader = bmh
   
    dim as FB.Image ptr img = imageCreate(w, h, RGBA(0,0,0,0),32)
    if (img = 0) then
        deleteObject(icoInfo.hbmMask)
        deleteObject(icoInfo.hbmColor)
        return 0
    end if
   
    ' Check alignment.
    ' We cannot use getDIBits, if the bits used per row don't match the width
    ' times the bits per pixel. getDIBits does not account for the padding in
    ' each row. Icons usually have a width that is a multiple of 16. Thus,
    ' generally, we shouldn't have an alignment issue.
    ' As a remedy, if there is padding, we could use a temporary buffer that we
    ' pass to getDIBits and then copy the buffer (with padding) to the image.
    assert(img->pitch = w*(img->bpp))
    if img->pitch <> w*(img->bpp) then
        imageDestroy(img)
        deleteObject(icoInfo.hbmMask)
        deleteObject(icoInfo.hbmColor)
        return 0
    end if
   
    ' Get colourmap.
    getDIBits(getDC(0), icoInfo.hbmColor, 0, h, getPixelAddress(img,0,0), _
        @bmi, DIB_RGB_COLORS)
   
    ' Get binary transparent(white)/opaque(black) mask.
    dim as ulong ptr imgb = callocate(w*h,sizeof(ulong))
    getDIBits(getDC(0), icoInfo.hbmMask, 0, h, imgb, @bmi, DIB_RGB_COLORS)
   
    ' Determine whether the original icon is 32-bit or lower.
    ' If the original icon is 32-bit but fully transparent and did not set the
    ' bitmask to white, then this script will, erroneously, think that the
    ' original image has a bitrate lower than 32.
    for i as integer = 0 to img->height-1
        for j as integer = 0 to img->width-1
            dim as ubyte ptr p = getPixelAddress(img,i,j)+3
            if (*p > 0) then
                deleteObject(icoInfo.hbmMask)
                deleteObject(icoInfo.hbmColor)
                return img
            end if
        next j
    next i
   
    ' We have determined that the original image is not 32-bit. Thus the alpha
    ' channel is set to completely transparent. We will now fix that.
    ' Generally 24-bit encoding doesn't allow for transparency information.
    ' However the icon comes with a bitmask which determines if a pixel is
    ' fully opaque or fully transparent.
    ' We will now make use of it and set the pixels accordingly.
    ' Note: We only need to act, if the bitmask defines a pixel to be fully
    '       opaque (since it already is fully transparent).
    '       Fully opaque is encoded as "black", i.e., zero.
    for i as integer = 0 to img->height-1
        for j as integer = 0 to img->width-1
            dim as const ulong src_transparencyMask = *(imgb+i*w+j)
            if (src_transparencyMask = 0) then
                dim as ubyte ptr alpha_byte = getPixelAddress(img,i,j)+3
                *alpha_byte = 255
            end if
        next j
    next i
    deleteObject(icoInfo.hbmMask)
    deleteObject(icoInfo.hbmColor)
   
    return img
end function


dim as HICON hLargeIcon, hSmallIcon
dim as FB.Image ptr smallIcon, largeIcon

screenres 640,480,32
color(0,RGBA(225,225,225,225))
cls

dim as string icons(1 to 8) = { _
    $"C:\WINDOWS\System32\shell32.dll", _
    $"ico1.ico", _
    $"ico2.ico", _
    $"ico3.ico", _
    $"ico4.ico", _
    $"ico5.ico", _
    $"C:\Program Files (x86)\Dropbox\Client\Dropbox.exe", _
    $"C:\Windows\notepad.exe"}

for i as integer = lbound(icons) to ubound(icons)
    if fileExists(icons(i)) then
        extractIconEx(icons(i), 0, @hLargeIcon, @hSmallIcon, 1)
        smallIcon = hIcon2fbImage(hSmallIcon)
        largeIcon = hIcon2fbImage(hLargeIcon)
        destroyIcon(hSmallIcon)
        destroyIcon(hLargeIcon)
        if smallIcon then
            put (100, 10+50*(i-1)), smallIcon, ALPHA
            imageDestroy(smallIcon)
        end if
        if largeIcon then
            put (150, 10+50*(i-1)), largeIcon, ALPHA
            imageDestroy(largeIcon)
        end if
    end if
next i
sleep

Mit folgendem Code hatte ich gehofft die Bitrate feststellen zu können:
Code:
getObject(icoInfo.hbmColor, sizeof(BITMAP), @bitmask)
print bitmask.bmBitsPixel,bitmask.bmWidthBytes/bitmask.bmWidth*8

Leider gibt dies immer 32-bit zurück.

Hat jemand eine Idee, wie man das Problem lösen kann?
Eine kürzere Implementierung als die obige wäre auch wünschenswert.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1208
Wohnort: Ruhrpott

BeitragVerfasst am: 26.03.2016, 12:06    Titel: Antworten mit Zitat

Hallo noop!

Ich bin mir nicht sicher, ob ich richtig verstanden habe, was dein eigentliches Problem ist, aber der Alphakanal lässt sich bei Bedarf auch nachträglich füllen:
Code:
...
If icon2 Then
   '********************************
   'alphakanal füllen
   Dim As UInteger breite, hoehe, transparenzfarbe
   Dim As UInteger Ptr pixdata
   ImageInfo(icon2, breite, hoehe,,,pixdata)
   transparenzfarbe = pixdata[0]
   For x As UInteger =  0 To breite * hoehe
      If pixdata[x] <> transparenzfarbe Then
         pixdata[x] Or= RGBA(0,0,0,255)
      EndIf
   Next
   '********************************
   Put (90,50),icon2,Alpha
   Put (90,90),icon2,PSet
   ImageDestroy(icon2)
End If
...

Die Farbe des 1. Pixels (obere linke Ecke) des Images dient dabei als Transparenzfarbe.

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
noop



Anmeldungsdatum: 04.05.2005
Beiträge: 259

BeitragVerfasst am: 26.03.2016, 16:59    Titel: Antworten mit Zitat

Hi grindstone,

ich merke gerade, dass mein obiger Post etwas wuchtig daherkommt grinsen


Hier eine Kurzbeschreibung:

A) Ein 24-bit Icon wird bei der Konvertierung transparent, da der Alpha-Kanal fehlt.
B) Ein 32-bit Icon wird, wie gewünscht, konvertiert.

Also müssen wir uns um A) kümmern.
Wir können einfach nachträglich den Alpha-Kanal mit dem Wert 255 füllen.
Problem: Woher wissen wir, ob ein Icon mit 32-bit oder 24-bit kodiert war?
Falls wir wir Windows danach fragen, so antwortet es immer mit 32-bit, also nicht hilfreich.

Für die folgende Beschreibung muss man wissen:
1) Ein Icon kommt mit einer Farbtablle und einer Transparenztabelle daher. Die Transparenztabelle ist dabei eine Bitmaske, d.h. es gibt nur die Zustände durchsichtig und undurchsichtig.
2) Ein 32-bit Icon muss die Transparenztabelle nicht korrekt setzen. Schließlich sind die Transparenzdaten schon im Alpha-Kanal enthalten. Anders sieht dies bei 24-bit Icons aus.

Ich habe Folgendes getan:
a) Ist das konvertierte Icon vollkommen transparent (laut Alpha-Kanal), so schaue ich mir die Transparenztabelle an.
Stimmen die Infos nicht überein, so gehe ich davon aus, dass es ein 24-bit Icon war und setze mit Hilfe der Transparenztabelle den Alpha-Kanal.
b) Ist das konvertierte Icon hingegen nicht vollkommen transparent (laut Alpha-Kanal), so war es 32-bit Icon.

Nun ergibt a) ein Problem: Auch ein 32-bit Icon darf vollkommen transparent sein. Dabei muss die Transparenztabelle nicht gefüllt worden sein.
In diesem Fall gehe ich fälschlicherweise davon aus, dass das Icon 24-bit kodiert ist. Da eine "leere" Transparenztabelle dem Zustand undurchsichtig entspricht, wird aus dem durchsichtigen Icon ein undurchsichtiges.

Abgesehen davon, dass ich den Spezialfall nicht richtig lösen kann, ist dieser Ansatz natürlich nicht sehr schön. Es wundert mich, dass man nicht einfach feststellen kann, welche Bitrate ein Icon hat (also smallIcon und largeIcon im obigen Code).
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
grindstone



Anmeldungsdatum: 03.10.2010
Beiträge: 1208
Wohnort: Ruhrpott

BeitragVerfasst am: 27.03.2016, 10:18    Titel: Antworten mit Zitat

In diesem Fall ist es wohl sinnvoller, die Füllroutine um eine entsprechende Prüfung zu erweitern und in die getfbimage zu verlagern.
Code:
#Include    Once "windows.bi"
#Include    Once "win\shellapi.bi"
#Include    Once "fbgfx.bi"

#define getPixelAddress(img,row,col) Cast(Any Ptr,img) + _
         SizeOf(FB.IMAGE) + img->pitch * row + img->bpp * col

ScreenRes 320,240,32
Color(0,RGBA(225,225,225,225))
Cls

Function getfbimage(ByVal filename As String) As FB.Image Ptr
   Dim As FB.Image Ptr mIcon = ImageCreate( 32 , 32 )

   '' Fenster handle
   Dim As HWND     mHwnd
   ScreenControl( FB.GET_WINDOW_HANDLE, Cast(Integer,mHwnd) )

   Dim As HICON hLargeIcon
   extractIconEx(filename, 0, @hLargeIcon, 0, 1)

   '' BitMap erstellen
   Dim As HDC      mHdc    = GetDC(mHwnd)
   Dim As HDC      hdcComp = CreateCompatibleDC(mHdc)
   Dim As HBITMAP  bitmap  = CreateCompatibleBitmap( mHdc , 32 , 32 )

   SelectObject( hdcComp , bitmap )

   Dim As BITMAPINFO bmi
   With bmi.bmiHeader
      .biSize = SizeOf(BITMAPINFOHEADER)
      .biWidth =  32
      .biHeight = -32
      .biPlanes = 1
      .biCompression = BI_RGB
      .biBitCount = 32
   End With

   '' Icon in die Bmp zeichnen
   DrawIconEx( hdcComp, 0, 0, hLargeIcon, 32, 32, 0, NULL, DI_NORMAL )

   '' fbImage erstellen/befüllen
   GetDIBits( hdcComp, bitmap, 0, 32, getPixelAddress(mIcon,0,0), @bmi, DIB_RGB_COLORS)
   
   '********************************
   'alphakanal füllen
   Dim As UInteger breite, hoehe, transparenzfarbe, x
   Dim As UInteger Ptr pixdata
   ImageInfo(mIcon, breite, hoehe,,,pixdata)
   For x =  0 To breite * hoehe - 1
      If pixdata[x] And RGBA(0,0,0,255) Then 'transparenzwert <> 0 gefunden
         Exit For
      EndIf
   Next
   If x = breite * hoehe Then 'alphakanal ist leer
      transparenzfarbe = pixdata[0]
      For x = 0 To breite * hoehe - 1
         If pixdata[x] <> transparenzfarbe Then
            pixdata[x] Or= RGBA(0,0,0,255)
         EndIf
      Next
   EndIf
   '********************************
   
   ReleaseDC( mHwnd , mHdc )
   DestroyIcon(hLargeIcon)
   DeleteDC(hdcComp)
   DeleteObject(bitmap)
   Return mIcon
End Function

Dim As FB.Image Ptr icon1 = getfbimage($"C:\Windows\notepad.exe")
Dim As FB.Image Ptr icon2 = getfbimage($"C:\WINDOWS\System32\shell32.dll")
If icon1 Then
   Put (50,50),icon1,Alpha
   Put (50,90),icon1,PSet
   ImageDestroy(icon1)
End If

If icon2 Then
   Put (90,50),icon2,Alpha
   Put (90,90),icon2,PSet
   ImageDestroy(icon2)
End If

GetKey

Zitat:
Auch ein 32-bit Icon darf vollkommen transparent sein.
Theoretisch ja, aber das Problem ist wohl eher akademisch, denn welchen Sinn sollte ein Icon haben, das komplett durchsichtig (=unsichtbar) ist?
Zitat:
Es wundert mich, dass man nicht einfach feststellen kann, welche Bitrate ein Icon hat
Das liegt daran, daß eine Datei dasselbe Icon mehrfach in verschiedenen Farbtiefen und Auflösungen enthalten kann. Die entsprechende Information wäre also nicht eindeutig.

Die obige Auswahl der Transparenzfarbe ist übrigens auch nicht ganz idiotensicher, aber da das auch von den entsprechenden WinAPI - Funktionen so gehandhabt wird, scheint mir das vertretbar zu sein.

Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
noop



Anmeldungsdatum: 04.05.2005
Beiträge: 259

BeitragVerfasst am: 31.03.2016, 16:11    Titel: Antworten mit Zitat

Hi grindstone,

grindstone hat Folgendes geschrieben:
In diesem Fall ist es wohl sinnvoller, die Füllroutine um eine entsprechende Prüfung zu erweitern und in die getfbimage zu verlagern.

Ja, dies hatte ich auch in meinem Code getan. Jedoch:
grindstone hat Folgendes geschrieben:
Zitat:
Auch ein 32-bit Icon darf vollkommen transparent sein.
Theoretisch ja, aber das Problem ist wohl eher akademisch, denn welchen Sinn sollte ein Icon haben, das komplett durchsichtig (=unsichtbar) ist?

Schon, allerdings stört es mich. Es ist schließlich erlaubt. Dann wäre es auch schön, wenn man dies implementieren kann.

grindstone hat Folgendes geschrieben:
Zitat:
Es wundert mich, dass man nicht einfach feststellen kann, welche Bitrate ein Icon hat
Das liegt daran, daß eine Datei dasselbe Icon mehrfach in verschiedenen Farbtiefen und Auflösungen enthalten kann. Die entsprechende Information wäre also nicht eindeutig.

Stimmt, daran hatte ich nicht gedacht.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Elor



Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz

BeitragVerfasst am: 01.04.2016, 09:35    Titel: Antworten mit Zitat

Suchst du vielleicht so was?
delphipraxis.net - Icon Header auslesen!
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
noop



Anmeldungsdatum: 04.05.2005
Beiträge: 259

BeitragVerfasst am: 06.04.2016, 09:50    Titel: Antworten mit Zitat

Hallo Elor,

ich habe es jetzt über diesen Weg implementiert. Es war eine schwere Geburt, da ich dies nicht nur für ico-Dateien, sondern auch für exe- und dll-Dateien implementieren "musste".
Es gibt allerdings weiterhin eine Situation, in der ich die Farbtiefe nicht feststellen kann: Bei manchen Icons ist einfach die Farbtiefe auf Null belassen worden. Man kann vermutlich anhand des Bildes die Farbtiefe ermitteln, aber darauf habe ich nun verzichtet. Insbesondere müsste ich mich dann mit der Analyse von PNG-Dateien beschäftigen (nein danke) oder es mit einer Bibliothek versuchen. Auf letzteres möchte ich gerne verzichten.

Ein weiterer Vorteil in meinem Code ist, dass man selbst das optimale Icon auswählen kann. Zuvor hatte Windows dies automatisch ausgewählt, was teilweise zu schlechten Ergebnissen führte. Nun kann man den Auswahlalgorithmus den eigenen Vorlieben anpassen.

Hier ist nun mein Code (ziemlich wuchtig geworden):
Code:
' This script extracts icons from ico-, exe- and dll-files and then
' converts them to an FB.Image and displays them.
'
' Black and white icons (i.e. icons with a color depth of 1) are not supported.
'
' See the function description of "hIcon2fbImage" for a caveat in the
' implementation.
'
' Tested with:
'    fbc-32-bit v1.05.0
'    fbc-64-bit v1.05.0
'
'
''''' Sample Code:
'
'screenres 640,480,32
'color(0,RGBA(225,225,225,225))
'cls
'
'dim as string icons(1 to 2) = { _
'    $"C:\WINDOWS\System32\shell32.dll", _
'    $"C:\Windows\notepad.exe"}
'
'dim as const integer prefResX = 256, prefResY = 256, prefBitDepth = 32
'for i as integer = lbound(icons) to ubound(icons)
'    dim as FB.Image ptr img = ICON_LOADER.loadIcon(icons(i),prefResX,prefResY,prefBitDepth,1)
'    if img then
'        put (10+(prefResX+5)*(i-1),100), img, ALPHA
'        imageDestroy(img)
'    end if
'next i
'sleep
'

#include once "fbgfx.bi"
#include once "windows.bi"
#include once "vbcompat.bi"

namespace ICON_LOADER

#ifndef getPixelAddress
    #define getPixelAddress(img,row,col) cast(any ptr,img) + _
        sizeof(FB.IMAGE) + (img)->pitch * (row) + (img)->bpp * (col)
#endif

type T_ICON
    icon as HICON
    as integer w,h,bpp
    declare constructor( _
            byval icon as HICON, _
            byval w as integer, byval h as integer, _
            byval bpp as integer)
    declare destructor()
end type

constructor T_ICON( _
            byval icon as HICON, _
            byval w as integer, byval h as integer, _
            byval bpp as integer)
    this.icon = icon
    this.w = w
    this.h = h
    this.bpp = bpp
end constructor

destructor T_ICON()
    destroyIcon(this.icon)
end destructor

type T_BASE_ICONDIR_ENTRY field = 1
    private:
    _width as const ubyte  ' A value of "0" means a width of 256.
    _height as const ubyte ' A value of "0" means a height of 256.
   
    public:
    declare const property width() as integer
    declare const property height() as integer
    cColorsInPalette as const ubyte  ' Number of colors in the color palette.
                                     ' Must be "0", if the color palette is
                                     ' missing. Is zero for images with a
                                     ' bitrate higher than 8.
    reserved as const ubyte     ' Should be "0".
    colorPlane as const ushort  ' Should be 0 or 1.
    bpp as ushort               ' bits per pixel (might not be specified)
    szImageData as const ulong  ' number of bytes of the image data
end type

public const property T_BASE_ICONDIR_ENTRY.width() as integer
    if this._width = 0 then
        return 256
    else
        return cast(uinteger,this._width)
    end if
end property

public const property T_BASE_ICONDIR_ENTRY.height() as integer
    if this._height = 0 then
        return 256
    else
        return cast(integer,this._height)
    end if
end property

type T_BASE_ICONDIR_HEADER field = 1
    reserved as const ushort     ' Must be "0".
    contentType as const ushort  ' Must be "1" for icon or "2" for cursor image.
    cEntries as const ushort     ' Number of images.
end type


type T_ICONDIR_ENTRY extends T_BASE_ICONDIR_ENTRY field = 1
    offsetImg as const ulong    ' Offset of image data from start of icon file.
end type

type T_GROUP_ICONDIR_ENTRY extends T_BASE_ICONDIR_ENTRY field = 1
    resID as const ushort       ' resource ID
end type

' We have two different structs extended from a parent struct. Both extended
' structs have different sizes. Thus, if we cast a pointer which points to an
' array of the structs, and access it as x[i], it will yield wrong results.
' We need to account for the differenz sizes. Therefore, first, we will cast
' "x" to a byte pointer and then add sizeof(originalStruct)*index.
' Afterwards, we cast the result back to the parent struct type "typeof(*x)".
#macro ao(x,i,szT)
    cptr( typeof(*(x)) ptr, _
           cptr(byte ptr,(x)) + (i)*(szT) _
         )
#endmacro

sub getSizeError( _
            byval x as const integer, byval xpref as const integer, _
            byval y as const integer, byval ypref as const integer, _
            byref errRatio as integer, byref errSize as integer)
    errRatio = 100*xpref/ypref-max(100*x/y,100*y/x)
    errSize = (x-xpref) + (y-ypref)
end sub

function getPreferredImage( _
            byval entries as const T_BASE_ICONDIR_ENTRY ptr, _
            byval szT as const integer, _
            byval cEntries as const integer, _
            byval prefResX as const integer, _
            byval prefResY as const integer, _
            byval prefBitDepth as const integer) as integer
    ' Find the icon image that resembles the preferred parameters the most.
    '    First find the images which are the closest in size.
    '       Images with the same ratio are preferred, even if they're much larger.
    '    Among them find the image with the same color depth as the preferred one.
    '       If that doesn't exist, find the image with a color depth which is
    '       larger and closest to the preferred one.
    '       If that doesn't exist, find the image with a color depth which is
    '       smaller and closest to the preferred one.
    '
    dim as integer imgID = -1
    if (cEntries <= 0) then return imgID
   
    ' The first image will be the reference image.
    imgID = 0
    dim as integer bestErrSize,bestErrRatio
    getSizeError( _
            ao(entries,imgID,szT)->width,prefResX, _
            ao(entries,imgID,szT)->height,prefResY, _
            bestErrRatio,bestErrSize)
    dim as integer bestErrBpp = ao(entries,imgID,szT)->bpp-prefBitDepth
    if (bestErrSize = 0) andAlso (bestErrRatio = 0) andAlso (bestErrBpp = 0) then
        return imgID
    end if
   
    ' Search through all other images for the best fit.
    for i as integer = 1 to cEntries-1
        ' Place the emphasis on finding an image with the same or approximately
        ' the same size.
        dim as integer errSize,errRatio
        getSizeError( _
                ao(entries,i,szT)->width,prefResX, _
                ao(entries,i,szT)->height,prefResY, _
                errRatio,errSize)
        dim as integer errBpp = ao(entries,i,szT)->bpp-prefBitDepth
        if (errRatio < bestErrRatio) then
            bestErrRatio = errRatio
            bestErrSize = errSize
            bestErrBpp = errBpp
            imgID = i
        elseif (errRatio = bestErrRatio) then
            if (bestErrSize < 0) then
                if (errSize > bestErrSize) then
                    bestErrRatio = errRatio
                    bestErrSize = errSize
                    bestErrBpp = errBpp
                    imgID = i
                end if
            elseif (bestErrSize > 0) then
                if (errSize >= 0) andAlso (errSize < bestErrSize) then
                    bestErrRatio = errRatio
                    bestErrSize = errSize
                    bestErrBpp = errBpp
                    imgID = i
                end if
            elseif (errSize = bestErrSize) then
                ' Among images with the same error in size, choose the image which
                ' fits the preferred color depth the most.
                ' That is.
                '    If the color depth is already the same: Nothing to do.
                '    If the color depth is higher than the preferred one, try to find
                '       one that is closer but still higher.
                '       Example:
                '          prefBitDepth = 8
                '          ao(entries,imgID,szT)->bpp = 32
                '          eligible color depths are: 8 <= bpp < 32
                '    If the color depth is smaller than the preferred one, try to find
                '       one that is closer or (arbitrarily) higher.
                '       Example:
                '          prefBitDepth = 8
                '          ao(entries,imgID,szT)->bpp = 1
                '          eligible color depths are: 1 < bpp
                '          Here, a color depth of 32 is preferable to 4.
               
                if (bestErrBpp < 0) andAlso (errBpp > bestErrBpp) then
                    bestErrRatio = errRatio
                    bestErrSize = errSize
                    bestErrBpp = errBpp
                    imgID = i
                elseif (bestErrBpp > 0) andAlso (errBpp > 0) andAlso (errBpp < bestErrBpp) then
                    bestErrRatio = errRatio
                    bestErrSize = errSize
                    bestErrBpp = errBpp
                    imgID = i
                end if
            end if
        end if
       
        ' No need to continue searching for a better fit, if the fit is already
        ' perfect.
        if (bestErrSize = 0) andAlso (bestErrRatio = 0) andAlso (bestErrBpp = 0) then
            return imgID
        end if
    next i
   
    return imgID
end function

sub determineColorDepth overload(byval entry as T_BASE_ICONDIR_ENTRY ptr)
    ' The color depth of the icon images can be zero (not specified).
    '    We cannot reliably determine the color depth by looking at the number
    '    of color planes or the number of colors in the palette.
    '    color planes:
    '       In new icons this is usually set to 1, independent of the color
    '       depth. But there are also many icons which set it to 0.
    '       According to wikipedia values greater than 1 are also possible.
    '    colors in palette:
    '       This should only be greater than 0, if the color depth is <= 8.
    '       If 256 colors are used, then this value will be zero.
    '       This value will also be zero for icons with more than 256 colors.
    '       If an icon has a color depth of 4 bit, then the number of colors
    '       doesn't have to equal 16. It can also be 15 or 14 etc.
    '       We could now use the number of colors in the palette to determine
    '       the bit rate for many icons. Say an icon uses 158 colors, then the
    '       color depth would be 8 bit. However here's the big problem:
    '       If this value is wrong and we pass the wrong color depth to Windows,
    '       then our programme will crash. However it will do just fine, if we
    '       leave the color depth specification blank.
    '       So rather than risking a crash, we will let Windows determine the
    '       correct color depth by analyzing the image data. Unfortunately
    '       we cannot query Windows for the color depth.
    '       This will influence how we select the icon that fits best to the
    '       user's preferences and also the conversion to an FB.Image.
    '       For the latter, see the function description of "hIcon2fbImage".
    '
    ' A not implemented alternative is to determine the color depth ourselves,
    ' by analyzing the image data (BMP- and PNG-format).
    '
end sub

sub determineColorDepth overload( _
            byval entries as T_BASE_ICONDIR_ENTRY ptr, _
            byval szT as const integer, _
            byval cEntries as const integer)
    for i as integer = 0 to cEntries-1
        dim as T_BASE_ICONDIR_ENTRY ptr entry = ao(entries,i,szT)
        ' First let's check whether the color depth is not specified.
        if ( entry->bpp = 0 ) then
            determineColorDepth(entry)
        end if
    next i
end sub

function enumProc( _
            byval hModule as HMODULE, _
            byval lpType as LPCSTR, _
            byval lpName as LPSTR, _
            byval lParam as LONG_PTR _
                 ) as WINBOOL
    ' Callback function for the enumeration of resource icons.
   
    ' Decrement counter.
    dim as integer cntr = *cast(integer ptr,lParam)
    cntr -= 1
   
    ' If the counter reaches zero, return the icon's resource ID "lpName".
    if (cntr = 0) then
        *cast(LPSTR ptr,lParam) = lpName
        return FALSE  ' stop enumerating
    else
        *cast(integer ptr,lParam) = cntr
        return CTRUE  ' keep enumerating
    end if
end function

function getIconFromLib overload( _
            byval hMod as const HMODULE, _
            byval iconPos as const integer, _
            byval prefResX as const integer, _
            byval prefResY as const integer, _
            byval prefBitDepth as const integer, _
            byval passThrough as const boolean = FALSE _
                       ) as T_ICON ptr
   
    ' Define the parameter to be passed to the callback function (for
    ' enumeration). We want to extract the n'th icon with n=iconPos.
    dim as integer param = iconPos
   
    enumResourceNames( _
        hMod, _                 ' library module handle
        RT_GROUP_ICON,  _       ' enumerate icon directory
        cast(ENUMRESNAMEPROCA,@enumProc), _  ' callback function
        cast(LONG_PTR,@param))  ' parameter
   
    ' When the enumeration finishes 'param' is either be zero (not enough icons)
    ' or it specifies the icon's resource ID.
    if (param = 0) then return 0
   
    ' Locate the icon's resource in the library.
    dim as HRSRC hResGroupIcon = findResource(hMod,cast(LPSTR,param),RT_GROUP_ICON)
    if (hResGroupIcon = 0) then return 0
   
    ' Get the handle to the icon's resource.
    dim as HGLOBAL hIconRes = loadResource(hMod, hResGroupIcon)
    if (hIconRes = 0) then return 0
   
    ' Using the icon's resource handle, retrieve a pointer to the memory location.
    dim as LPVOID pMemIcon = lockResource(hIconRes)
    if (pMemIcon = 0) then return 0
   
    ' Cast the memory pointer to a icon directory pointer.
    dim as T_BASE_ICONDIR_HEADER ptr iconDir = cptr(T_BASE_ICONDIR_HEADER ptr,pMemIcon)
   
    assert(iconDir->reserved = 0)
    if (iconDir->reserved <> 0) then return 0
   
    if (iconDir->cEntries <= 0) then return 0
   
    ' Get and assign the address of the image info structs.
    dim as T_GROUP_ICONDIR_ENTRY ptr entries = cptr( _
            T_GROUP_ICONDIR_ENTRY ptr, _
            cptr(any ptr,iconDir+1))
   
    ' If the color depth info is not specified for an image, try to determine it.
    determineColorDepth( _
            cptr(T_BASE_ICONDIR_ENTRY ptr,entries), _
            sizeof(*entries), _
            iconDir->cEntries)
   
    ' Of all available icon images, choose the best fit.
    dim as integer imgID = getPreferredImage( _
            cptr(T_BASE_ICONDIR_ENTRY ptr,entries), _
            sizeof(*entries), _
            iconDir->cEntries, _
            prefResX, prefResY, prefBitDepth)
    if (imgID < 0) then return 0
    dim as const integer resID = entries[imgID].resID
   
    ' Locate the image's resource in the library.
    dim as HRSRC hResImg = findResource(hMod, MAKEINTRESOURCE(resID),RT_ICON)
    if (hResImg = 0) then return 0
   
    ' Get the handle to the image's resource.
    dim as HGLOBAL hImageRes = loadResource(hMod, hResImg)
    if (hImageRes = 0) then return 0
    assert(entries[imgID].szImageData = sizeofResource(hMod, hResImg))
   
    ' Using the image's resource handle, retrieve a pointer to the memory location.
    dim as LPVOID pMemImg = lockResource(hImageRes)
    if (pMemImg = 0) then return 0
   
    ' Create an HICON from the image's resource.
    dim as HICON hIcon
    if passThrough then
        hIcon = createIconFromResourceEx( _
            cptr(byte ptr,pMemImg), _         ' address of the image bits
            sizeofResource(hMod, hResImg), _  ' size (in bytes) of the image data
            CTRUE, _               ' TRUE: icon
            &h00030000, _          ' version number of the icon format
            entries[imgID].width, entries[imgID].height, _  ' desired width and height in pixels
            LR_DEFAULTCOLOR)       ' LR_DEFAULTCOLOR: Use default color format.
    else
        hIcon = createIconFromResourceEx( _
            cptr(byte ptr,pMemImg), _         ' address of the image bits
            sizeofResource(hMod, hResImg), _  ' size (in bytes) of the image data
            CTRUE, _               ' TRUE: icon
            &h00030000, _          ' version number of the icon format
            prefResX, prefResY, _  ' desired width and height in pixels
            LR_DEFAULTCOLOR)       ' LR_DEFAULTCOLOR: Use default color format.
    end if
    if (hIcon = 0) then return 0
   
    dim as T_ICON ptr icon = new T_ICON( _
        hIcon,entries[imgID].width,entries[imgID].height,entries[imgID].bpp)
   
    return icon
end function

function getIconFromLib overload( _
            byval filename as const string, _
            byval iconPos as const integer = 1, _
            byval prefResX as const integer = 32, _
            byval prefResY as const integer = 32, _
            byval prefBitDepth as const integer = 32, _
            byval passThrough as const boolean = FALSE _
                       ) as T_ICON ptr
    ' Extract the icon image that fits best from the n'th icon (n=iconPos) from
    ' the library "filename".
   
    assert(iconPos >= 1)
    if (iconPos < 1) then return 0
   
    ' Load the library (exe or dll) as a datafile.
    ' This enables us to load 32-bit libraries as a 64-bit programme and
    ' vice versa.
    dim as HMODULE hMod = loadLibraryEx(filename,0,LOAD_LIBRARY_AS_DATAFILE)
    if (hMod = 0) then return 0
   
    dim as T_ICON ptr icon = getIconFromLib(hMod,iconPos,prefResX,prefResY, _
        prefBitDepth,passThrough)
   
    ' Release the data library.
    freeLibrary(hMod)
   
    return icon
end function


function getIconFromIco overload( _
            byval d as byte ptr, _
            byval prefResX as const integer, _
            byval prefResY as const integer, _
            byval prefBitDepth as const integer, _
            byval passThrough as const boolean = FALSE _
                       ) as T_ICON ptr
   
    ' icon format: little endian
    ' memory format: little endian
    dim as T_BASE_ICONDIR_HEADER ptr iconDir = cptr(T_BASE_ICONDIR_HEADER ptr,d)
   
    assert(iconDir->reserved = 0)
    if (iconDir->reserved <> 0) then return 0
   
    if (iconDir->cEntries <= 0) then return 0
   
    ' Make sure the icon file contains an icon and not a cursor.
    if (iconDir->contentType <> 1) then return 0
   
    ' Get and assign the address of the image info structs.
    dim as T_ICONDIR_ENTRY ptr entries = cptr( _
            T_ICONDIR_ENTRY ptr, _
            cptr(any ptr,iconDir+1))
   
    ' If the color depth info is not specified for an image, try to determine it.
    determineColorDepth( _
            cptr(T_BASE_ICONDIR_ENTRY ptr,entries), _
            sizeof(*entries), _
            iconDir->cEntries)
   
    ' Of all available icon images, choose the best fit.
    dim as integer imgID = getPreferredImage( _
            cptr(T_BASE_ICONDIR_ENTRY ptr,entries), _
            sizeof(*entries), _
            iconDir->cEntries, _
            prefResX, prefResY, prefBitDepth)
    if (imgID < 0) then return 0
   
    ' Create an HICON from the image's resource.
    dim as HICON hIcon
    if passThrough then
        hIcon = createIconFromResourceEx( _
            d+entries[imgID].offsetImg, _  ' address of the image bits
            entries[imgID].szImageData, _  ' size (in bytes) of the image data
            CTRUE, _               ' TRUE: icon
            &h00030000, _          ' version number of the icon format
            entries[imgID].width, entries[imgID].height, _  ' desired width and height in pixels
            LR_DEFAULTCOLOR)       ' LR_DEFAULTCOLOR: Use default color format.
    else
        hIcon = createIconFromResourceEx( _
            d+entries[imgID].offsetImg, _  ' address of the image bits
            entries[imgID].szImageData, _  ' size (in bytes) of the image data
            CTRUE, _               ' TRUE: icon
            &h00030000, _          ' version number of the icon format
            prefResX, prefResY, _  ' desired width and height in pixels
            LR_DEFAULTCOLOR)       ' LR_DEFAULTCOLOR: Use default color format.
    end if
    if (hIcon = 0) then return 0
   
    dim as T_ICON ptr icon = new T_ICON( _
        hIcon,entries[imgID].width,entries[imgID].height,entries[imgID].bpp)
   
    return icon
end function

function getIconFromIco overload( _
            byval filename as const string, _
            byval prefResX as const integer = 32, _
            byval prefResY as const integer = 32, _
            byval prefBitDepth as const integer = 32, _
            byval passThrough as const boolean = FALSE _
                       ) as T_ICON ptr
    ' Extract the icon image which fits best from the icon "filename".
   
    ' Load the icon file into memory.
    dim as long ff = freeFile()
    if ( open(filename for binary access read as #ff) <> 0 ) then return 0
    '
    dim as const integer lenFile = lof(ff)
    if (lenFile <= 0) then return 0
    '
    dim as byte ptr d = callocate(lenFile,sizeof(byte))
    if (d = 0) then
        close #ff
        return 0
    end if
    '
    if ( get(#ff,1,d[0],lenFile) <> 0 ) then
        close #ff
        return 0
    end if
    close #ff
   
    dim as T_ICON ptr icon = getIconFromIco(d,prefResX,prefResY,prefBitDepth, _
        passThrough)
   
    ' Release icon from memory.
    deallocate(d)
   
    return icon
end function

sub fixTransparency(byval img as FB.Image ptr, byval imgb as ulong ptr)
    ' We have determined that the original image is not 32-bit. Thus the alpha
    ' channel is set to completely transparent. We will now fix that.
    ' Generally 24-bit encoding doesn't allow for transparency information.
    ' However the icon comes with a bitmask which determines if a pixel is
    ' fully opaque or fully transparent.
    ' We will now make use of it and set the pixels accordingly.
    ' Note: We only need to act, if the bitmask defines a pixel to be fully
    '       opaque (since it already is fully transparent).
    '       Fully opaque is encoded as "black", i.e., zero.
    dim as const integer w = img->width
    dim as const integer h = img->height
    for i as integer = 0 to h-1
        for j as integer = 0 to w-1
            dim as const ulong src_transparencyMask = *(imgb+i*w+j)
            if (src_transparencyMask = 0) then
                dim as ubyte ptr alpha_byte = getPixelAddress(img,i,j)+3
                *alpha_byte = 255
            end if
        next j
    next i
end sub

function isFullyTransparent(byval img as FB.Image ptr) as boolean
    for i as integer = 0 to img->height-1
        for j as integer = 0 to img->width-1
            dim as const ubyte ptr p = getPixelAddress(img,i,j)+3
            if (*p > 0) then return FALSE
        next j
    next i
    return TRUE
end function
   
function hIcon2fbImage(byval hIcon as HICON, byval bpp as const integer = 0) as FB.Image ptr
    ' This function converts an HICON to an FB.Image.
    '
    ' Important:
    '    1) This implementation does not account for black&white icons.
    '    2) If the color depth wasn't specified and the icon is fully transparent,
    '       stored in 32-bit and didn't set the transparency-mask, then you
    '       will get a fully opaque icon with whatever background color was used.
    '          The implementation is hacky. I couldn't find a robust way to
    '          determine if the bitrate of the originally loaded icon is 32-bit
    '          or lower. Unfortunately Windows doesn't fill the alpha
    '          channel, so that when displaying it using alpha channels, the
    '          icon will be fully transparent. The following occurs if the bit
    '          depth is not specified via "bpp":
    '          a) The icon is 32-bit and has some alpha values which are not 0
    '             (i.e. not fully transparent). In that case the script finds
    '             these pixels and knows that the icon was originally in 32-bit.
    '          b) The icon is 32-bit but is completely transparent (all alpha
    '             values are zero). Furthermore the transparency bitmask was
    '             not set (i.e. it's all zero). Due to all-zero alpha values
    '             the script does not know that it's a 32-bit image. It will
    '             then look at the bitmask. If the bitmask says "this pixel is
    '             opaque" (i.e. the the pixel has a value of zero in the
    '             bitmask), then the script will assume that the image has a
    '             bitrate lower than 32. Since the bitmask is fully zero, it
    '             will, erroneously, set the image as fully opaque.
    '          c) The icon has a bitrate lower than 32-bit. Then all alpha
    '             values will be zero. The script will then use the bitmask to
    '             determine if a pixel is supposed to be fully opaque or fully
    '             transparent.
    '    3) This implementation assumes that "standard" icons  are used, i.e.,
    '       icons with a width that is a multiple of 16. Otherwise memory
    '       alignment issues require another step (using a temporary buffer).
    '
   
    dim as ICONINFO icoInfo
    dim as BITMAP bitmask
    if getIconInfo(hIcon, @icoInfo) = FALSE then return 0
    if getObject(icoInfo.hbmMask, sizeof(BITMAP), @bitmask) = FALSE then
        deleteObject(icoInfo.hbmMask)
        deleteObject(icoInfo.hbmColor)
        return 0
    end if
   
    dim as integer w,h
    w = bitmask.bmWidth
    h = bitmask.bmHeight
   
    dim as BITMAPINFO bmi
    dim as BITMAPINFOHEADER bmh
    with bmh
        .biSize = sizeof(BITMAPINFOHEADER)
        .biWidth = w
        .biHeight = -h
        .biPlanes = 1
        .biCompression = BI_RGB
        .biBitCount = 32
        .biSizeImage = w*h*4
    end with
    bmi.bmiHeader = bmh
   
    dim as FB.Image ptr img = imageCreate(w, h, RGBA(0,0,0,0),32)
    if (img = 0) then
        deleteObject(icoInfo.hbmMask)
        deleteObject(icoInfo.hbmColor)
        return 0
    end if
   
    ' Check alignment.
    ' We cannot use getDIBits, if the bits used per row don't match the width
    ' times the bits per pixel. getDIBits does not account for the padding in
    ' each row. Icons usually have a width that is a multiple of 16. Thus,
    ' generally, we shouldn't have an alignment issue.
    ' As a remedy, if there is padding, we could use a temporary buffer that we
    ' pass to getDIBits and then copy the buffer (with padding) to the image.
    assert(img->pitch = w*(img->bpp))
    if img->pitch <> w*(img->bpp) then
        imageDestroy(img)
        deleteObject(icoInfo.hbmMask)
        deleteObject(icoInfo.hbmColor)
        return 0
    end if
   
    ' Get colormap.
    getDIBits(getDC(0), icoInfo.hbmColor, 0, h, getPixelAddress(img,0,0), _
        @bmi, DIB_RGB_COLORS)
   
    dim as boolean doFixTransparency = FALSE
    if (bpp > 0) then
        if (bpp < 32) then doFixTransparency = TRUE
    else
        ' Determine whether the original icon is 32-bit or lower.
        ' If the original icon is 32-bit but fully transparent and did not set the
        ' bitmask to white, then this script will, erroneously, think that the
        ' original image has a bitrate lower than 32.
        doFixTransparency = isFullyTransparent(img)
    end if
   
    if doFixTransparency then
        ' Get binary transparent(white)/opaque(black) mask.
        dim as ulong ptr imgb = callocate(w*h,sizeof(ulong))
        getDIBits(getDC(0), icoInfo.hbmMask, 0, h, imgb, @bmi, DIB_RGB_COLORS)
       
        fixTransparency(img,imgb)
       
        deallocate(imgb)
    end if
   
    deleteObject(icoInfo.hbmMask)
    deleteObject(icoInfo.hbmColor)
   
    return img
end function

function loadIcon( _
            byval filename as string, _
            byval prefResX as const integer = 32, _
            byval prefResY as const integer = 32, _
            byval prefBitDepth as const integer = 32, _
            byval iconPos as const integer = 1, _
            byval passThrough as const boolean = FALSE _
                 ) as FB.Image ptr
    ' Extract the icon image that fits best from the n'th icon (n=iconPos) from
    ' the file "filename" (ico/exe/dll). As a source, use an icon image fits
    ' best to the preferred with, height and color depth.
    ' The returned image has a color depth of 32.
    '
    ' passThrough = TRUE: Don't scale the icon image if it doesn't fit.
   
    if fileExists(filename) then
        dim as const string ext = lcase(right(filename,4))
        dim as T_ICON ptr icon = 0
        if (ext = ".ico") then
            icon = getIconFromIco(filename,prefResX,prefResY,prefBitDepth, _
                    passThrough)
        elseif (ext = ".exe") orElse (ext = ".dll") then
            icon = getIconFromLib(filename,iconPos,prefResX,prefResY, _
                    prefBitDepth,passThrough)
        end if
       
        if (icon <> 0) then
            dim as FB.Image ptr img = hIcon2fbImage(icon->icon,icon->bpp)
            delete(icon)
            return img
        else
            return 0
        end if
    else
        return 0
    end if
end function

end namespace

screenres 480,320,32
color(0,RGBA(225,225,225,225))
cls

dim as string icons(1 to 5) = { _
    $"C:\WINDOWS\System32\shell32.dll", _
    $"ico1.ico", _
    $"C:\Program Files (x86)\Dropbox\Client\Dropbox.exe", _
    $"C:\Windows\notepad.exe", _
    $"C:\WINDOWS\System32\shell32.dll"}

dim as const integer prefResX = 32, prefResY = 32, prefBitDepth = 32
for i as integer = lbound(icons) to ubound(icons)
    dim as FB.Image ptr img
    if (i = ubound(icons)) then
        img = ICON_LOADER.loadIcon(icons(i),prefResX,prefResY,prefBitDepth,2)
    else
        img = ICON_LOADER.loadIcon(icons(i),prefResX,prefResY,prefBitDepth)
    end if
    if img then
        put (10+(prefResX+5)*(i-1),100), img, ALPHA
        imageDestroy(img)
    end if
next i
sleep


Edit: Code update (nichts Nennenswertes verändert)


Zuletzt bearbeitet von noop am 09.04.2016, 13:39, insgesamt einmal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Elor



Anmeldungsdatum: 12.07.2013
Beiträge: 205
Wohnort: Konstanz

BeitragVerfasst am: 08.04.2016, 12:10    Titel: Antworten mit Zitat

Also das mit dem auslesen der Bit tiefe scheint ja ein generelles Problem zu sein, zumindest wenn man sich so in den Foren um guckt. Es gibt noch einen Beitrag auf ActiveVB-Forum, der auch eine Funktion zum auslesen der Bitrate enthält. Ausprobiert hab ich es nicht, aber vielleicht enthält der Beitrag ja noch Informationen die du für dein Projekt verwenden kannst?
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
noop



Anmeldungsdatum: 04.05.2005
Beiträge: 259

BeitragVerfasst am: 09.04.2016, 13:37    Titel: Antworten mit Zitat

Danke für den Link, Elor. Ich habe es mir angeschaut und dachte anfänglich, dass dies einen Fehler in meiner Implementierung aufzeigt.
Allerdings habe ich dann festgestellt, dass der "Zustand von Icons" noch schlimmer ist, als anfangs gedacht. Die Werte sind nie eindeutig.
Die einzige wirklich sichere Methode scheint zu sein, die Bilddaten zu analysieren. Dies ist natürlich sehr aufwendig.
Ich habe zu dem verlinkten Beitrag einen Kommentar hinterlassen.

Man kann zwar anhand der verfügbaren Information recht sicher feststellen, welche Farbtiefe ein Bild hat, jedoch ist meine am Anfang vorgestellte heuristische Methode deutlich robuster.

Übermittelt man außerdem Windows einen falschen Wert zur Farbtiefe, so stürzt das Programm ab. Lässt man den Wert undefiniert, so versucht Windows selbst den richtigen Wert herauszufinden (nur kommuniziert Windows leider nicht, was es herausgefunden hat).

Es ist schon seltsam, dass etwas derart Primitives so verkorkst ist zwinkern
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Windows-spezifische Fragen Alle Zeiten sind GMT + 1 Stunde
Seite 1 von 1

 
Gehe zu:  
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.

 Impressum :: Datenschutz