Чтобы получить и отобразить на форме иконку, используемую системой для определённого типа файлов, необходимо: иметь контейнер для отображения этой иконки и знать расширение файла :). В качестве контейнера это может быть системная иконка формы либо любой элемент управления, принимающий изображение. Итак, для работы понадобится форма и модуль:
Документ с примером
1 Option Explicit
2
3 Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
4 (lpPictDesc As PictDesc, _
5 riid As Guid, _
6 ByVal fPictureOwnsHandle As Long, _
7 ipic As IPicture) As Long
8 Public Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" _
9 (ByVal hInst As Long, _
10 ByVal lpIconPath As String, _
11 lpiIcon As Long) As Long
12 Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
13 (ByVal lpClassName As String, _
14 ByVal lpWindowName As String) As Long
15 Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
16 (ByVal hwnd As Long, _
17 ByVal wMsg As Long, _
18 ByVal wParam As Long, _
19 ByVal lParam As Long) As Long
20 Public Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
21
22 Public Const WM_SETICON = &H80
23
24 Private Type PictDesc
25 cbSizeofStruct As Long
26 picType As Long
27 hImage As Long
28 xExt As Long
29 yExt As Long
30 End Type
31 Private Type Guid
32 Data1 As Long
33 Data2 As Integer
34 Data3 As Integer
35 Data4(0 To 7) As Byte
36 End Type
37
38 Public Function IconToPicture(ByVal hIcon As Long) As IPicture
39
40 If hIcon = 0 Then Exit Function
41
42 Dim oNewPic As IPicture
43 Dim tPicConv As PictDesc
44 Dim IGuid As Guid
45
46 With tPicConv
47 .cbSizeofStruct = Len(tPicConv)
48 .picType = 3 'vbPicTypeIcon
49 .hImage = hIcon
50 End With
51
52 ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
53 With IGuid
54 .Data1 = &H7BF80980
55 .Data2 = &HBF32
56 .Data3 = &H101A
57 .Data4(0) = &H8B
58 .Data4(1) = &HBB
59 .Data4(2) = &H0
60 .Data4(3) = &HAA
61 .Data4(4) = &H0
62 .Data4(5) = &H30
63 .Data4(6) = &HC
64 .Data4(7) = &HAB
65 End With
66 OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic
67
68 Set IconToPicture = oNewPic
69 DestroyIcon hIcon
70 End Function
71
1 Option Explicit
2
3 Dim hwnd As Long
4 Dim hIcon As Long
5
6 Private Sub CommandButton1_Click()
7 If hwnd <> 0 Then
8 hIcon = ExtractAssociatedIcon(hwnd, Application.ActiveDocument.FullName, 0)
9 Image1.Picture = IconToPicture(hIcon)
10 End If
11 End Sub
12
13 Private Sub CommandButton2_Click()
14 If hwnd <> 0 Then
15 hIcon = ExtractAssociatedIcon(hwnd, Application.ActiveDocument.FullName, 0)
16 SendMessage hwnd, WM_SETICON, 0, hIcon
17 End If
18 End Sub
19
20 Private Sub UserForm_Initialize()
21 hwnd = FindWindow("ThunderDFrame", Me.Caption)
22 Me.Caption = "&H" & Hex(hwnd)
23 End Sub
Комментариев нет:
Отправить комментарий