IconExtractToPic

'==== Per Funzione GetIcoFile

Private Const MAX_PATH = 260 'Max Path Len
Private Const SHGFI_ICON = &H100 'get icon
Private Const SHGFI_ICONLOCATION = &H1000 'get icon location
Private Const SHGFI_LARGEICON = &H0 'get large icon
Private Const SHGFI_OPENICON = &H2 'get open icon
Private Const SHGFI_SHELLICONSIZE = &H4 'get shell size icon
Private Const SHGFI_SMALLICON = &H1 'get small icon
Private Type SHFILEINFO
hIcon As Long ' out: icon
iIcon As Long ' out: icon index
dwAttributes As Long ' out: SFGAO_ flags
szDisplayName As String * MAX_PATH ' out: display name (or path)
szTypeName As String * 80 ' out: type name
End Type
'==== Per funzione ConvertIcon

Private Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'==============

Public Function GetIcoFile(FileName As String) As Long
'In : Nome file con percorso completo

'Out : Handle dell'icona associata al file

' Ritorna 0 se non c'e` icona o se il file non esiste

On Error GoTo errore
Dim Info As SHFILEINFO
Dim x As Long
SHGetFileInfo FileName, 0, Info, CLng(Len(Info)), SHGFI_ICON
GetIcoFile = Info.hIcon
Exit Function
errore:
GetIcoFile = 0
End Function

Public Function ConvertIcon(hIcon) As Picture
'In: Handle di un'icona

'Out: Ritorna una picture

'Esempio: Picture1=ConvertIcon(hicon)

On Error GoTo errore
'Se manca handle

If hIcon = 0 Then Exit Function
Dim NewPic As Picture, PicConv As PictDesc, IGuid As Guid
PicConv.cbSizeofStruct = Len(PicConv)
PicConv.picType = vbPicTypeIcon
PicConv.hImage = hIcon
IGuid.Data1 = &H20400
IGuid.Data4(0) = &HC0
IGuid.Data4(7) = &H46
Call OleCreatePictureIndirect(PicConv, IGuid, True, NewPic)
Set ConvertIcon = NewPic
Exit Function
errore:
MsgBox Err.Description, vbCritical, App.EXEName &
":RikSysIcons.ConvertIcon"
End Function