Как получить системную иконку для определённого файла?

Чтобы получить и отобразить на форме иконку, используемую системой для определённого типа файлов, необходимо: иметь контейнер для отображения этой иконки и знать расширение файла :). В качестве контейнера это может быть системная иконка формы либо любой элемент управления, принимающий изображение. Итак, для работы понадобится форма и модуль:

 1 
 2 
 3 
 4 
 5 
 6 
 7 
 8 
 9 
10 
11 
12 
13 
14 
15 
16 
17 
18 
19 
20 
21 
22 
23 
24 
25 
26 
27 
28 
29 
30 
31 
32 
33 
34 
35 
36 
37 
38 
39 
40 
41 
42 
43 
44 
45 
46 
47 
48 
49 
50 
51 
52 
53 
54 
55 
56 
57 
58 
59 
60 
61 
62 
63 
64 
65 
66 
67 
68 
69 
70 
71 
Option Explicit
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
                        (lpPictDesc As PictDesc, _
                        riid As Guid, _
                        ByVal fPictureOwnsHandle As Long, _
                        ipic As IPicture) As Long
Public Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" _
                        (ByVal hInst As Long, _
                        ByVal lpIconPath As String, _
                        lpiIcon As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
                        (ByVal lpClassName As String, _
                        ByVal lpWindowName As String) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                        (ByVal hwnd As Long, _
                        ByVal wMsg As Long, _
                        ByVal wParam As Long, _
                        ByVal lParam As Long) As Long
Public Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long

Public Const WM_SETICON = &H80

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 IconToPicture(ByVal hIcon As Long) As IPicture
    
    If hIcon = 0 Then Exit Function
        
    Dim oNewPic As IPicture
    Dim tPicConv As PictDesc
    Dim IGuid As Guid
    
    With tPicConv
       .cbSizeofStruct = Len(tPicConv)
       .picType = 3 'vbPicTypeIcon
       .hImage = hIcon
    End With
    
    ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
    With IGuid
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic
    
    Set IconToPicture = oNewPic
    DestroyIcon hIcon
End Function

 1 
 2 
 3 
 4 
 5 
 6 
 7 
 8 
 9 
10 
11 
12 
13 
14 
15 
16 
17 
18 
19 
20 
21 
22 
23 
Option Explicit

Dim hwnd As Long
Dim hIcon As Long

Private Sub CommandButton1_Click()
    If hwnd <> 0 Then
        hIcon = ExtractAssociatedIcon(hwnd, Application.ActiveDocument.FullName, 0)
        Image1.Picture = IconToPicture(hIcon)
    End If
End Sub

Private Sub CommandButton2_Click()
    If hwnd <> 0 Then
        hIcon = ExtractAssociatedIcon(hwnd, Application.ActiveDocument.FullName, 0)
        SendMessage hwnd, WM_SETICON, 0, hIcon
    End If
End Sub

Private Sub UserForm_Initialize()
    hwnd = FindWindow("ThunderDFrame", Me.Caption)
    Me.Caption = "&H" & Hex(hwnd)
End Sub

Документ с примером