Foro de elhacker.net

Option Explicit

Private Type PicBmp
   Size As Long
   tType As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type

Public FILE_SHELL As String

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 ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hicon As Long) As Long

Public Sub GetIconFromFile(ByRef Lista As ImageList, FileName As String, iconIndex As Long, UseLargeIcon As Boolean) ' As Picture
    Dim X As Long
    ' Parametros:
    ' FileName - Nombre Fichero (EXE o DLL) que contiene los iconos
    ' IconIndex - Indice del icono a extraer, comienza en 0
    ' UseLargeIcon-True para icono grande, False para icono pequeño
    ' Returns: Objeto Picture, donde devolvera el icono
   
    Dim hlargeicon As Long, hsmallicon As Long, selhandle As Long
    
    ' El objeto requiere una referencia a "Standard OLE Types"
    Dim pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID
    X = 0
    'While ExtractIconEx(FileName, X, hlargeicon, hsmallicon, 1) <> 0
        If ExtractIconEx(FileName, iconIndex - 1, hlargeicon, hsmallicon, 1) <> 0 Then
            If UseLargeIcon Then
                selhandle = hlargeicon
            Else
                selhandle = hsmallicon
            End If
            
            With IID_IDispatch
                .Data1 = &H20400
                .Data4(0) = &HC0
                .Data4(7) = &H46
            End With
            
            ' Fill Pic with necessary parts.
            ' Configura el picture con las partes necesarias
            With pic
                .Size = Len(pic) ' Longitud de la extructura.
                .tType = vbPicTypeIcon ' Tipo de Picture (bitmap).
                .hBmp = selhandle ' Handle al bitmap.
            End With
            
            ' Crea el objeto Picture
            Call OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)
            
            ' Devuelve el objeto Picture
            Lista.ListImages.Add , , IPic
            
            'Set GetIconFromFile = IPic
            
            DestroyIcon hsmallicon
            DestroyIcon hlargeicon
            X = X + 1
        End If
    'Wend
End Sub

GetIconFromFile ImageList1, "c:\windows\system32\shell32.dll", Numero_de_icono, True
picture1.Picture = ImageList1.ListImages(1).Picture