Ugly icons...[RESOLVED]

[pax]

Hi Pirate.

I finally got some of it to work. I'm sorry to say that I didn't use your code.

It turns out that it had been working all the time, except on the icons I had tried. Now I coincidently choose another index and it worked. So it works on some icons and not on others.

Now, ain't that some weird S**t?

Now I don't know what to do with the other icons. Perhaps they don't have an alphachannel?

Here's my code. Maybe you can figure it out?

Imports System.Runtime.InteropServices
Imports System.Drawing.Imaging
 
Public Class IconExtraction
 
#Region "API"
    <DllImport("shell32.dll", EntryPoint:="ExtractIconEx", CharSet:=CharSet.Auto)> _
    Private Shared Function ExtractIconEx(ByVal Filename As String, ByVal IconIndex As Integer, ByRef hIconLarge As IntPtr, ByRef hIconSmall As IntPtr, ByVal IconCount As Integer) As IntPtr
    End Function
 
    <DllImport("shell32.dll", EntryPoint:="SHGetFileInfo", CharSet:=CharSet.Auto)> _
    Private Shared Function SHGetFileInfo(ByVal FileName As String, ByVal FileAttributes As Integer, ByRef Buffer As SHFileInfo, ByVal FileInfo As Integer, ByVal Flags As Integer) As IntPtr
    End Function
 
    <DllImport("user32", EntryPoint:="GetIconInfo", CharSet:=CharSet.Auto)> _
    Private Shared Function GetIconInfo(ByVal hIcon As IntPtr, ByRef piconinfo As ICONINFO) As IntPtr
    End Function
 
    <DllImport("Gdi32", EntryPoint:="CreateDC", CharSet:=CharSet.Auto)> _
    Private Shared Function CreateDC(ByVal Driver As String, ByVal DeviceName As String, ByVal Output As String, ByVal Mode As IntPtr) As IntPtr
    End Function
 
    <DllImport("Gdi32", EntryPoint:="GetDeviceCaps", CharSet:=CharSet.Auto)> _
    Private Shared Function GetDeviceCaps(ByVal hDC As IntPtr, ByVal Index As Integer) As Integer
    End Function
 
    <DllImport("Gdi32", EntryPoint:="DeleteDC", CharSet:=CharSet.Auto)> _
    Private Shared Function DeleteDC(ByVal hDC As IntPtr) As Boolean
    End Function
 
    <DllImport("user32", EntryPoint:="DestroyIcon", CharSet:=CharSet.Auto)> _
    Private Shared Function DestroyIcon(ByVal hIcon As IntPtr) As IntPtr
    End Function
#End Region
 
#Region "Structures"
    Private Structure SHFileInfo
        Public hIcon As IntPtr
        Public iIcon As Integer
        Public dwAttributes As Integer
        Public szDisplayName As String
        Public szTypeName As String
    End Structure
    Private Structure ICONINFO
        Dim fIcon As Boolean
        Dim xHotspot As Integer
        Dim yHotspot As Integer
        Dim hbmMask As IntPtr
        Dim hbmColor As IntPtr
    End Structure
 
#End Region
 
#Region "Constants"
    Private Const SHGFI_ICON = &H100
    Private Const SHGFI_SMALLICON = &H1   ' Small icon
    Private Const SHGFI_LARGEICON = &H0   ' Large icon
    Private Const SHGFI_USEFILEATTRIBUTES = &H10
 
    Private Const BITSPIXEL As Integer = 12
    Private Const PLANES As Integer = 14
#End Region
 
#Region "Private Functions"
    'Used by the alphafix
    Private Shared Function GetColorDepth() As Integer
        Dim screenDC As IntPtr = CreateDC("DISPLAY", Nothing, Nothing, IntPtr.Zero)
        Dim bitDepth As Integer = GetDeviceCaps(screenDC, BITSPIXEL)
        bitDepth *= GetDeviceCaps(screenDC, PLANES)
        DeleteDC(screenDC)
        Return bitDepth
    End Function
    Private Shared Function FixAlphaBitmap(ByVal bmSource As Bitmap) As Bitmap
 
        'WARNING! This function will fail if the passed bitmap is not of
        'the correct Pixelformat.
        Dim bmData As Imaging.BitmapData
        Dim bmBounds As New Rectangle(0, 0, bmSource.Width, bmSource.Height)
 
        'create a new bitmap with an ARGB format and point it to the same memory
        'location as the original bitmap.
        bmData = bmSource.LockBits(bmBounds, ImageLockMode.ReadOnly, bmSource.PixelFormat)
        Dim dstBitmap As New Bitmap(bmData.Width, bmData.Height, bmData.Stride, PixelFormat.Format32bppArgb, bmData.Scan0)
        bmSource.UnlockBits(bmData)
 
        bmData = Nothing
 
        Return dstBitmap
 
    End Function
#End Region
 
    Public Shared Function GetIconCount(ByVal FileName As String) As Integer
        Dim hCount As IntPtr
 
        hCount = ExtractIconEx(FileName, -1, Nothing, Nothing, 1)
 
        Return hCount.ToInt32
    End Function
 
    Public Shared Function ExtractLargeIcon(ByVal FileName As String, ByVal Index As Integer) As Icon
        Dim hIcon As IntPtr
 
        ExtractIconEx(FileName, Index, hIcon, Nothing, 1)
 
        Return Icon.FromHandle(hIcon)
    End Function
    Public Shared Function ExtractSmallIcon(ByVal FileName As String, ByVal Index As Integer) As Icon
        Dim hIcon As IntPtr
 
        ExtractIconEx(FileName, Index, Nothing, hIcon, 1)
 
        Return Icon.FromHandle(hIcon)
    End Function
 
    Public Shared Function ExtractLargeAssociatedIcon(ByVal FileName As String) As Icon
        Dim sh As New SHFileInfo()
 
        SHGetFileInfo(FileName, 0, sh, Marshal.SizeOf(sh), SHGFI_ICON Or SHGFI_LARGEICON Or SHGFI_USEFILEATTRIBUTES)
 
        GC.Collect()
 
        Return Icon.FromHandle(sh.hIcon)
    End Function
    Public Shared Function ExtractSmallAssociatedIcon(ByVal FileName As String) As Icon
        Dim sh As New SHFileInfo()
 
        SHGetFileInfo(FileName, 0, sh, Marshal.SizeOf(sh), SHGFI_ICON Or SHGFI_SMALLICON Or SHGFI_USEFILEATTRIBUTES)
 
        GC.Collect()
 
        Return Icon.FromHandle(sh.hIcon)
 
    End Function
 
    Public Shared Function ConvertToBitmap(ByVal hIcon As IntPtr) As Bitmap
        Dim B As Bitmap
        Dim hBitmap As IntPtr
        Dim bmp As Bitmap
        Dim ii As New ICONINFO()
 
        GetIconInfo(hIcon, ii)
        hBitmap = ii.hbmColor
        bmp = Bitmap.FromHbitmap(hBitmap)
        If Environment.OSVersion.Version.Major >= 5 AndAlso _
         Environment.OSVersion.Version.Minor >= 1 AndAlso _
         GetColorDepth() = 32 Then
            B = FixAlphaBitmap(bmp).Clone
        Else
            B = Bitmap.FromHicon(hIcon)
        End If
        DestroyIcon(hBitmap)
        DestroyIcon(hIcon)
 
        GC.Collect()
 
        hBitmap = Nothing
        bmp = Nothing
        ii = Nothing
 
        Return B
 
    End Function
End Class