Re: How to get an associated file icon without the Alpha Channel i

From: Mark Collard (MarkCollard_at_discussions.microsoft.com)
Date: 09/07/04 

Date: Tue, 7 Sep 2004 01:03:02 -0700

It works great for files with a 32 bit icon, but doesn't work for files with
a non 32 bit icon e.g. C:\WINDOWS\winhelp.exe

I've pasted the code below and wondering if you could please fix the code so
it'll create the non 32 bit icons as well.

Thank you

Regards
Mark

Create a Form and add a PictureBox, a CommandButton and a TextBox control.
Then pasted the following code into the Form
Option Explicit

Private Sub Command1_Click()

    Dim objIcon As StdPicture
    
    Call gGetFileInfo(Text1.Text, objIcon)
    
    Set Picture1.Picture = objIcon

End Sub

Private Sub Form_Load()

    Text1.Text = "C:\WINDOWS\winhelp.exe"

End Sub

Then paste the following code into a Module
Option Explicit

    Private Enum SHGFIConstants
        SHGFI_LARGEICON = &H0 ' sfi.hIcon is large icon
        SHGFI_SMALLICON = &H1 ' sfi.hIcon is small icon
        SHGFI_OPENICON = &H2 ' sfi.hIcon is open icon
        SHGFI_SHELLICONSIZE = &H4 ' sfi.hIcon is shell size (not
system size), rtns BOOL
        SHGFI_PIDL = &H8 ' pszPath is pidl, rtns BOOL
        SHGFI_USEFILEATTRIBUTES = &H10 ' pretend pszPath exists, rtns BOOL
        SHGFI_ICON = &H100 ' fills sfi.hIcon, rtns BOOL, use
DestroyIcon
        SHGFI_DISPLAYNAME = &H200 ' isf.szDisplayName is filled, rtns
BOOL
        SHGFI_TYPENAME = &H400 ' isf.szTypeName is filled, rtns BOOL
        SHGFI_ATTRIBUTES = &H800 ' rtns IShellFolder::GetAttributesOf
 SFGAO_* flags
        SHGFI_ICONLOCATION = &H1000 ' fills sfi.szDisplayName with
filename
                                        ' containing the icon, rtns BOOL
        SHGFI_EXETYPE = &H2000 ' rtns two ASCII chars of exe type
        SHGFI_SYSICONINDEX = &H4000 ' sfi.iIcon is sys il icon index,
rtns hImagelist
        SHGFI_LINKOVERLAY = &H8000 ' add shortcut overlay to sfi.hIcon
        SHGFI_SELECTED = &H10000 ' sfi.hIcon is selected icon
    End Enum
    
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(7) As Byte
    End Type
    Private Type PICBMP
        cbSize As Long
        picType As Long
        hImage As Long
        xExt As Long
        yExt As Long
    End Type
    Private Type SHFILEINFO
        hIcon As Long
        iIcon As Long
        dwAttributes As Long
        szDisplayName As String * 260
        szTypeName As String * 80
    End Type
    
Private Type IconInfo
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type

Private Type Bitmap ' 24 bytes
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Private Type BitmapInfoHeader ' 40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Const DIB_RGB_COLORS As Long = &H0 ' Color table in RGBs
' Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long)
As Long
' Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long,
ByRef pIconInfo As IconInfo) As Long
' Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
' Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As
Long) As Long
' Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As
Long) As Long
' Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long,
ByVal hObject As Long) As Long
' Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long,
ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long,
ByRef lpBits As Any, ByRef lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
' Private Declare Function SetDIBits Lib "gdi32" (ByVal hDC As Long,
ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long,
ByRef lpBits As Any, ByRef lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
' Private Declare Function CreateIconIndirect Lib "User32.dll" (ByRef
pIconInfo As IconInfo) As Long
' Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

    Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias
"SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long,
psfi As SHFILEINFO, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As
Long
    Private Declare Function OleCreatePictureIndirect Lib "OLEPRO32.DLL"
(PicDesc As PICBMP, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As
IPicture) As Long
Private Declare Function GetIconInfo Lib "User32.dll" (ByVal hIcon As Long,
ByRef pIconInfo As IconInfo) As Long
Private Declare Function GetObject Lib "GDI32.dll" Alias "GetObjectA" (ByVal
hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function DeleteObject Lib "GDI32.dll" (ByVal hObject As
Long) As Long
Private Declare Function CreateCompatibleDC Lib "GDI32.dll" (ByVal hDC As
Long) As Long
Private Declare Function SelectObject Lib "GDI32.dll" (ByVal hDC As Long,
ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function GetDIBits Lib "GDI32.dll" (ByVal aHDC As Long,
ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long,
ByRef lpBits As Any, ByRef lpBIH As BitmapInfoHeader, ByVal wUsage As Long)
As Long
Private Declare Function SetDIBits Lib "GDI32.dll" (ByVal hDC As Long, ByVal
hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, ByRef
lpBits As Any, ByRef lpBIH As BitmapInfoHeader, ByVal wUsage As Long) As Long
Private Declare Function GetBitmapBits Lib "GDI32.dll" (ByVal hBitmap As
Long, ByVal dwCount As Long, ByRef lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "GDI32.dll" (ByVal hBitmap As
Long, ByVal dwCount As Long, ByRef lpBits As Any) As Long
Private Declare Function SetPixelV Lib "GDI32.dll" (ByVal hDC As Long, ByVal
X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function CreateIconIndirect Lib "User32.dll" (ByRef
pIconInfo As IconInfo) As Long

Public Sub gGetFileInfo(ByVal Filename As String, _
                        ByRef FileIcon As StdPicture)

    ' Declarations:
    Dim udtPicture As PICBMP
    Dim objFilleIcon As StdPicture
    Dim udtIID_IDispatch As GUID
    Dim udtFileInfo As SHFILEINFO
    Dim lngNewIconHandle As Long
        
    ' Retrieve the file info
    If SHGetFileInfo(Filename, _
                     0&, _
                     udtFileInfo, _
                     Len(udtFileInfo), _
                     SHGFI_ICON Or _
                     SHGFI_SMALLICON) <> 0 Then
                                                                             
    
        ' Fill the IDispatch Interface
        With udtIID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        
        lngNewIconHandle = ThresholdIconAlpha(udtFileInfo.hIcon, _
                                              255)
        
        ' Fill the Picture variable
        With udtPicture
            .cbSize = Len(udtPicture)
            .picType = vbPicTypeIcon
            .hImage = lngNewIconHandle
        End With
        
        ' Create Picture object
        Call OleCreatePictureIndirect(udtPicture, _
                                      udtIID_IDispatch, _
                                      0, _
                                      objFilleIcon)
        
        ' Return a reference to the file icon
        Set FileIcon = objFilleIcon
            
    End If
    
End Sub

Public Function ThresholdIconAlpha(ByVal inIcon As Long, ByVal inThreshold
As Byte) As Long
    Dim IconInf As IconInfo
    Dim BMInf As Bitmap
    Dim hMaskDC As Long, hOldBMP As Long
    Dim BMIHead As BitmapInfoHeader
    Dim BMData() As Long
    Dim LoopX As Long, LoopY As Long, FlipY As Long
    
    Const HighByte As Long = &HFF000000
    Const HighShift As Long = &H1000000
    Const LowByte As Long = &HFF&
    
    ' Grab information about input icon and its colour Bitmap
    If (GetIconInfo(inIcon, IconInf) = 0) Then Exit Function
    If ((GetObject(IconInf.hbmColor, Len(BMInf), BMInf) = 0) Or _
        (BMInf.bmBitsPixel <> 32)) Then ' Not 32-bit; no alpha
        Call DeleteObject(IconInf.hbmColor)
        Call DeleteObject(IconInf.hbmMask)
        ThresholdIconAlpha = inIcon
        Exit Function
    End If
    
    ' Create temporary device context
    hMaskDC = CreateCompatibleDC(0&)
    
    BMIHead.biSize = Len(BMIHead) ' Grab Bitmap header information
    If (GetDIBits(hMaskDC, IconInf.hbmColor, 0, 0, ByVal 0&, BMIHead,
DIB_RGB_COLORS) <> 0) Then
        ' Allocate Bitmap data buffer
        ReDim BMData(0 To (BMIHead.biWidth - 1), 0 To (BMIHead.biHeight -
1)) As Long
        
        If (BMInf.bmBits) Then ' Extract DIB data
            Call GetDIBits(hMaskDC, IconInf.hbmColor, 0, BMIHead.biHeight,
BMData(0, 0), BMIHead, DIB_RGB_COLORS)
        Else ' Extract DDB data
            Call GetBitmapBits(IconInf.hbmColor, BMInf.bmWidthBytes *
BMInf.bmHeight, BMData(0, 0))
        End If
        
        ' Select mask into DC
        hOldBMP = SelectObject(hMaskDC, IconInf.hbmMask)
        
        For LoopY = 0 To BMIHead.biHeight - 1
            If ((BMInf.bmBits = 0) Or (BMIHead.biHeight < 0)) Then
                 ' DDB data or top down DIB
                FlipY = LoopY
            Else ' Bottom up DIB data, flip draw coordinate
                FlipY = (BMIHead.biHeight - 1) - LoopY
            End If
            
            For LoopX = 0 To BMIHead.biWidth - 1 ' Check alpha byte against
input threshold
                If ((((BMData(LoopX, LoopY) And HighByte) \ HighShift) And
LowByte) >= inThreshold) Then
                    BMData(LoopX, LoopY) = BMData(LoopX, LoopY) Or HighByte
                    Call SetPixelV(hMaskDC, LoopX, FlipY, vbBlack) ' Show
this one
                Else
                    BMData(LoopX, LoopY) = BMData(LoopX, LoopY) And Not
BMData(LoopX, LoopY)
                    Call SetPixelV(hMaskDC, LoopX, FlipY, vbWhite) ' Hide
this one
                End If
            Next LoopX
        Next LoopY
        
        ' De-select mask bitmap from DC
        Call SelectObject(hMaskDC, hOldBMP)
        
        If (BMInf.bmBits) Then ' Set DIB data
            Call SetDIBits(hMaskDC, IconInf.hbmColor, 0, BMIHead.biHeight,
BMData(0, 0), BMIHead, DIB_RGB_COLORS)
        Else ' Set DDB data
            Call SetBitmapBits(IconInf.hbmColor, BMInf.bmWidthBytes *
BMInf.bmHeight, BMData(0, 0))
        End If
    End If
    
    ' Destroy temporary DC
    Call DeleteDC(hMaskDC)
    
    ' Create and return new icon
    ThresholdIconAlpha = CreateIconIndirect(IconInf)
    
    ' Destroy source Bitmaps
    Call DeleteObject(IconInf.hbmColor)
    Call DeleteObject(IconInf.hbmMask)
End Function

Loading