Извлечение иконки и сохранение в PNG

Данный пример показывает как просто и доступно работать с Api функциями GDI+ библиотеки. В примере иконка извлекается из файла explorer.exe и сохраняется в формате PNG. Хотя сохранять можно и в других форматах, достаточно поменять расширение файла и CLSID:

BMP {557CF400-1A04-11D3-9A73-0000F81EF32E}
JPEG {557CF401-1A04-11D3-9A73-0000F81EF32E}
GIF {557CF402-1A04-11D3-9A73-0000F81EF32E}
TIFF {557CF405-1A04-11D3-9A73-0000F81EF32E}
PNG {557CF406-1A04-11D3-9A73-0000F81EF32E}

Платформы: Windows.
Автор: Hard, создано в 2009 году

#INCLUDE Once "WINDOWS.BI"

#INCLUDE Once "WIN/SHELLAPI.BI"


#INCLUDE Once "WIN/GDIPLUS.BI"


Using GDIPLUS

Dim ULONG_PTR_01 As ULONG_PTR

Dim GDIPLUSSTARTUPINPUT_01 As GDIPLUSSTARTUPINPUT

GDIPLUSSTARTUPINPUT_01.GdiplusVersion = 1


If (GDIPLUSSTARTUP(@ULONG_PTR_01, @GDIPLUSSTARTUPINPUT_01, NULL) <> 0) Then

        Print "FAIL"
Endif

Dim SHFILEINFOA_01 As SHFILEINFO

If (SHGETFILEINFO("C:\WINDOWS\explorer.exe", 0, @SHFILEINFOA_01, Sizeof(SHFILEINFOA_01), SHGFI_ICON Or SHGFI_LARGEICON) <> 1) Then

        Print "FAIL"
Endif

Dim ICONINFO_01 As ICONINFO

If (GETICONINFO(SHFILEINFOA_01.hIcon, @ICONINFO_01) = 0) Then

        Print "FAIL"
Endif

Dim BITMAP_01 As BITMAP

If (GETOBJECT(ICONINFO_01.hbmColor, Sizeof(BITMAP), @BITMAP_01) = 0) Then

        Print "FAIL"
Endif

Dim GPIMAGE_00 As GPIMAGE Ptr

Dim GPIMAGE_01 As GPIMAGE Ptr


If (GDIPCREATEBITMAPFROMHBITMAP(ICONINFO_01.hbmColor, NULL, @GPIMAGE_00) <> 0) Then

        Print "FAIL"
Endif

Dim GPRECT_01 As GPRECT

GPRECT_01.X = 0

GPRECT_01.Y = 0

GPRECT_01.Width = BITMAP_01.bmWidth
GPRECT_01.Height = BITMAP_01.bmHeight

Dim PIXELFORMAT_01 As PIXELFORMAT

If (GDIPGETIMAGEPIXELFORMAT(GPIMAGE_00, @PIXELFORMAT_01) <> 0) Then

        Print "FAIL"
Endif

Dim BOOLEAN_01 As BOOLEAN

If PIXELFORMAT_01 <> PIXELFORMAT32BPPRGB Then

        BOOLEAN_01 = TRUE
Else

        Dim BITMAPDATA_01 As BITMAPDATA
        
        If (GDIPBITMAPLOCKBITS(GPIMAGE_00, @GPRECT_01, IMAGELOCKMODE.IMAGELOCKMODEREAD, PIXELFORMAT_01, @BITMAPDATA_01) <> 0) Then

                Print "FAIL"
        Endif
        
        If (GDIPCREATEBITMAPFROMSCAN0(BITMAPDATA_01.Width, BITMAPDATA_01.Height, BITMAPDATA_01.Stride, PIXELFORMAT32BPPARGB, BITMAPDATA_01.Scan0, @GPIMAGE_01) <> 0) Then

                Print "FAIL"
        Endif
        
        Dim BYTE_01 As Ubyte Ptr

        
        BYTE_01 = Callocate(3)
        
        For FOR_01 As Integer = 0 To BITMAP_01.bmWidth-1

            For FOR_02 As Integer = 0 To BITMAP_01.bmHeight-1

                        COPYMEMORY BYTE_01, BITMAPDATA_01.Scan0 + (FOR_01 * BITMAPDATA_01.Stride) + (FOR_02 * 4), 4

                        
                        If (BYTE_01[3] > 0) And (BYTE_01[3] < 255) Then

                                BOOLEAN_01 = TRUE
                            
                            Exit For

                        Endif
            Next

            
            If BOOLEAN_01 = TRUE Then

                    Exit For

            Endif
        Next

        
        Deallocate BYTE_01
        
        If (GDIPBITMAPUNLOCKBITS(GPIMAGE_00, @BITMAPDATA_01) <> 0) Then

                Print "FAIL"
        Endif
Endif

DELETEOBJECT ICONINFO_01.hbmColor

DELETEOBJECT ICONINFO_01.hbmMask

If BOOLEAN_01 = FALSE Then

        GDIPDISPOSEIMAGE GPIMAGE_01
        
        If (GDIPCREATEBITMAPFROMHICON(SHFILEINFOA_01.HICON, @GPIMAGE_01) <> 0) Then

                Print "FAIL"
        Endif
Endif

DESTROYICON SHFILEINFOA_01.hIcon

Dim CLSID_01 As CLSID

CLSIDFROMSTRING Wstr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), @CLSID_01

If (GDIPSAVEIMAGETOFILE(GPIMAGE_01, Wstr("1.png"), @CLSID_01 , NULL) <> 0) Then

        Print "FAIL"
Endif

GDIPDISPOSEIMAGE GPIMAGE_01

GDIPLUSSHUTDOWN ULONG_PTR_01

FreeBasic

Извлечение иконки и сохранение в PNG