-
Notifications
You must be signed in to change notification settings - Fork 39
/
ModuleGetFileIcon.bas
98 lines (80 loc) · 2.61 KB
/
ModuleGetFileIcon.bas
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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
Attribute VB_Name = "ModuleGetFileIcon"
'****************************************************************
'
' Ty2y杀毒软件
' http://www.ty2y.com/
'
' 获取文件图标
'
'****************************************************************
Option Explicit
'API声明
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (pDicDesc As TypeIcon, riid As CLSID, ByVal fown As Long, lpUnk As Object) As Long
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
'常量定义
Private Const SHGFI_ICON = &H100
Private Const SHGFI_LARGEICON = &H0
Private Const SHGFI_bSmallIcon = &H1
'自定义类型
Private Type TypeIcon
cbSize As Long
picType As PictureTypeConstants
hIcon As Long
End Type
Private Type CLSID
id(16) As Byte
End Type
Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * 255
szTypeName As String * 80
End Type
'****************************************************************
'
' ICON 转 Picture
' 参数: hIcon 图标句柄
'
'****************************************************************
Public Function IconToPicture(hIcon As Long) As IPictureDisp
Dim cls_id As CLSID
Dim hRes As Long
Dim new_icon As TypeIcon
Dim lpUnk As IUnknown
With new_icon
.cbSize = Len(new_icon)
.picType = vbPicTypeIcon
.hIcon = hIcon
End With
With cls_id
.id(8) = &HC0
.id(15) = &H46
End With
hRes = OleCreatePictureIndirect(new_icon, cls_id, 1, lpUnk)
If hRes = 0 Then
Set IconToPicture = lpUnk
End If
End Function
'****************************************************************
'
' 获得文件ICON
' 参数:sFilename 文件名(全路径)
' bSmallIcon boolean型,传入true为16*16小图标,传入false
' 为32*32大图标
'
'****************************************************************
Public Function GetFileIcon(sFilename, ByVal bSmallIcon As Boolean) As IPictureDisp
Dim hIcon As Long
Dim item_num As Long
Dim icon_pic As IPictureDisp
Dim sh_info As SHFILEINFO
If bSmallIcon = True Then
SHGetFileInfo sFilename, 0, sh_info, Len(sh_info), SHGFI_ICON + SHGFI_bSmallIcon
Else
SHGetFileInfo sFilename, 0, sh_info, Len(sh_info), SHGFI_ICON + SHGFI_LARGEICON
End If
hIcon = sh_info.hIcon
Set icon_pic = IconToPicture(hIcon)
Set GetFileIcon = icon_pic
End Function