Чтобы получить и отобразить на форме иконку, используемую системой для определённого типа файлов, необходимо: иметь контейнер для отображения этой иконки и знать расширение файла :). В качестве контейнера это может быть системная иконка формы либо любой элемент управления, принимающий изображение. Итак, для работы понадобится форма и модуль:
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 |
Документ с примером
Комментариев нет:
Отправить комментарий