Attribute VB_Name = "modExtractAssociatedIcon"
Option Explicit



Private Const SHGFI_ATTRIBUTES  As Long = &H800
Private Const SHGFI_DISPLAYNAME As Long = &H200
Private Const SHGFI_EXETYPE As Long = &H2000
Private Const SHGFI_ICON As Long = &H100
Private Const SHGFI_ICONLOCATION As Long = &H1000
Private Const SHGFI_LARGEICON As Long = &H0
Private Const SHGFI_LINKOVERLAY As Long = 32768 '= &H8000
Private Const SHGFI_OPENICON As Long = &H2
Private Const SHGFI_PIDL As Long = &H8
Private Const SHGFI_SELECTED As Long = &H10000
Private Const SHGFI_SHELLICONSIZE As Long = &H4
Private Const SHGFI_SMALLICON As Long = &H1
Private Const SHGFI_SYSICONINDEX As Long = &H4000
Private Const SHGFI_TYPENAME As Long = &H400
Private Const SHGFI_USEFILEATTRIBUTES As Long = &H10
Private Const MAX_PATH = 260

Private Type SHFILEINFO
  hIcon As Long
  iIcon As Long
  dwAttributes As Long
  szDisplayName As String * MAX_PATH
  szTypeName As String * 80
End Type

Private Declare Function SHGetFileInfo Lib "shell32.dll" _
 Alias "SHGetFileInfoA" (ByVal pszPath As String, _
 ByVal dwFileAttributes As Long, psfi As SHFILEINFO, _
 ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
 
Public Enum shgfiFlags
  shgfiLarge = SHGFI_LARGEICON
  shgfiLink = SHGFI_LINKOVERLAY
  shgfiOpen = SHGFI_OPENICON
  shgfiSelected = SHGFI_SELECTED
  shgfiShell = SHGFI_SHELLICONSIZE
  shgfiSmall = SHGFI_SMALLICON
End Enum


' *** Den Artikel zu diesem Modul finden Sie unter http://www.aboutvb.de/khw/artikel/khwpicturefromhandle.htm ***

Private Type PICTDESC
    cbSizeofStruct As Long
    PicType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type

Private Type GUID
    Part1 As Long
    Part2 As Integer
    Part3 As Integer
    Part4 As Integer
    Part5(1 To 6) As Byte
End Type

Private Declare Function OleCreatePictureIndirect Lib "Olepro32" (ByRef pPictDesc As PICTDESC, ByRef RIID As GUID, ByVal fOwn As Long, ByRef ppvObj As Any) As Long
Private Declare Function IIDFromString Lib "OLE32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long

Public Function PictureFromHandle(ByVal Handle As Long, ByVal PictureType As PictureTypeConstants, Optional ByVal PictureOwnsHandle As Boolean = False) As StdPicture
    Dim nPicture As Picture
    Dim nPictDesc As PICTDESC
    Dim nIID As GUID
    Dim nHResult As Long
    
    Const kPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
    
    With nPictDesc
        .cbSizeofStruct = Len(nPictDesc)
        .PicType = PictureType
        .hImage = Handle
    End With
    nHResult = IIDFromString(StrConv(kPictureIID, vbUnicode), nIID)
    If nHResult Then
        Err.Raise nHResult
    Else
        nHResult = OleCreatePictureIndirect(nPictDesc, nIID, PictureOwnsHandle, nPicture)
        If nHResult Then
            Err.Raise nHResult
        Else
            Set PictureFromHandle = nPicture
        End If
    End If
End Function



Public Function GetDisplayedIcon( _
 ByRef strFilename As String, _
 Optional ByVal lngFlags As shgfiFlags = shgfiLarge) _
 As StdPicture

  Dim fi As SHFILEINFO
  Dim lngReturn As Long
  
  lngFlags = lngFlags Or SHGFI_ICON
  lngReturn = SHGetFileInfo(strFilename, 0, fi, Len(fi), lngFlags)
  If lngReturn = 0 Then
    Err.Raise 5
  End If
  Set GetDisplayedIcon = _
   PictureFromHandle(fi.hIcon, vbPicTypeIcon, True)
End Function

