Visual Basic Programming Code Examples

Visual Basic > Files Directories Drives Code Examples

Extracting the icon from a file



Extracting the icon from a file

The following code an demonstration routine, illustrate how to extract icons from files:

Option Explicit

Private Type tPicBmp
   Size As Long
   Type 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

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As tPicBmp, 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

'Purpose     :  Extracts an icon from a file
'Inputs      :  sFileName               The file to extract the icon from
'               [lIconIndex]            The zero based index of the icon to extract (some files can contain more than one icon).
'               [bUseLargeIcon]         If True extracts a 32x32 icon else extracts 16x16 icon.
'Outputs     :  Returns the icon as an StdPicture


Public Function IconFromFile(sFileName As String, Optional lIconIndex As Long = 0, Optional bUseLargeIcon As Boolean = False) As StdPicture
    Dim lhwndLargeIcon As Long, lhwndSmallIcon As Long, lhwndSelected As Long
    Dim tPic As tPicBmp, IPic As IPicture
    Dim IID_IDispatch As GUID

    If ExtractIconEx(sFileName, lIconIndex, lhwndLargeIcon, lhwndSmallIcon, 1) > 0 Then
        If bUseLargeIcon Then
            lhwndSelected = lhwndLargeIcon
        Else
            lhwndSelected = lhwndSmallIcon
        End If
    
        'Fill in with IDispatch Interface ID.
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        
        'Fill tPic with necessary parts.
        With tPic
            .Size = Len(tPic)       'Length of structure.
            .Type = 3               'vbPicTypeIcon, type of Picture (bitmap).
            .hBmp = lhwndSelected   'Handle to bitmap.
        End With
    
        'Create Picture object.
        Call OleCreatePictureIndirect(tPic, IID_IDispatch, 1, IPic)
    
        'Return the new Picture object.
        Set IconFromFile = IPic
        
        DestroyIcon lhwndSmallIcon
        DestroyIcon lhwndLargeIcon
        
    End If
End Function


'Extracts an icon from an EXE and saves it to the root in the C: drive
Sub Test()
    Dim Picture1 As StdPicture, lCount As Long, sExcelPath As String
    
    'Extracts icons from Excel.exe
    sExcelPath = "C:\Program Files\Microsoft Office\Office\excel.exe"
    Do
        If Len(Dir$(sExcelPath)) Then
            'Specified valid path to excel
            Exit Do
        ElseIf Len(sExcelPath) Then
            'Path to Excel is incorrect
            sExcelPath = InputBox("Please enter the path to the file Excel.exe:", , sExcelPath)
        Else
            MsgBox "Aborted"
            End
        End If
    Loop
    Do
        Set Picture1 = IconFromFile(sExcelPath, lCount, True)
        'Save the icon
        If (Picture1 Is Nothing) = False Then
            lCount = lCount + 1
            On Error Resume Next
            VBA.Kill "C:\excel" & lCount & ".ico"
            On Error GoTo 0
            SavePicture Picture1, "C:\excel" & lCount & ".ico"
            Set Picture1 = Nothing
        Else
            'Finished extracting icons
            Exit Do
        End If
    Loop
End Sub