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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
Option Compare Database
Option Explicit
Private Declare Function GetObjectBmp Lib "gdi32" Alias "GetObjectA" _
(ByVal hObject As Long, ByVal nCount As Long, lpObject As bitmap) As Long
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pPath As String, _
ByVal dwFileAttributes As Long, ByRef psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function GetIconInfo Lib "USER32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
Private Declare Function DestroyIcon Lib "user32.dll" (ByVal hIcon As Long) As Long
Private Declare Function DrawIconEx Lib "user32.dll" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function apiGetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal length As Long)
Private Declare Function GetDC Lib "USER32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, pBitmapInfo As BitmapInfo, ByVal un As Long, _
lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" _
(ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Type bitmap
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type BitmapInfoHeader
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type DIBSECTION
dsBm As bitmap
dsBmih As BitmapInfoHeader
dsBitfields(2) As Long
dshSection As Long
dsOffset As Long
End Type
Private Type BitmapInfo
bmiHeader As BitmapInfoHeader
bmiColors(0 To 255) As Long
End Type
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type
Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * 260
szTypeName As String * 80
End Type
Private Const SHGFI_ICON = &H100
Private Const BI_RGB As Long = &H0
Private Const DIB_RGB_COLORS As Long = &H0
Public Function GetIconPictureData(pPath As String, Optional pLargeIcon As Boolean, Optional ByVal pIconBackColor As Long = vbWhite) As Variant
Dim lLoadhBmp As bitmap
Dim lpicinfo As ICONINFO
Dim lIcon As Long, lBrush As Long, lHdc As Long, lHdcRef As Long
Dim lhDIB As Long, lDIBPTR As Long, lhOldDIB As Long
Dim lsfi As SHFILEINFO
Dim lExtensionOnly As Boolean
Dim lIconType As Long
Dim lBI As BitmapInfo
Dim lPicData() As Byte
Dim lds As DIBSECTION
On Error GoTo Gestion_Erreurs
' Pour compatibilite anciennes versions
If Not pLargeIcon Then
lIconType = &H1
Else
lIconType = &H0
End If
' Si uniquement extension
If Len(pPath) <= 6 And Left(pPath, 1) = "." Then lExtensionOnly = True
' Recupere l'icone
Call SHGetFileInfo(ByVal pPath, IIf(lExtensionOnly, &H80, 0), lsfi, Len(lsfi), IIf(lExtensionOnly, &H10, 0) Or SHGFI_ICON Or lIconType)
If lsfi.hIcon = 0 Then GetIconPictureData = Null: Exit Function
lIcon = lsfi.hIcon
' Informations de l'icone
GetIconInfo lIcon, lpicinfo
' Lecture des infos du bitmap de l'icone
Call GetObjectBmp(lpicinfo.hbmColor, Len(lLoadhBmp), lLoadhBmp)
' Taille de l'en-tete
lBI.bmiHeader.biSize = Len(lBI.bmiHeader)
' Taille de l'image = taille de l'objet
lBI.bmiHeader.biWidth = lLoadhBmp.bmWidth
lBI.bmiHeader.biHeight = lLoadhBmp.bmHeight
' Compression RGB (pas de compression en fait)
lBI.bmiHeader.biCompression = BI_RGB
' 24bits
lBI.bmiHeader.biBitCount = 24
' Nombre de plans : toujours = 1 (d'apres MSDN)
lBI.bmiHeader.biPlanes = 1
' Taille de l'image à zéro, sera calculée par gdi32
lBI.bmiHeader.biSizeImage = 0
' DC de reference
lHdcRef = GetDC(0)
' Device context
lHdc = CreateCompatibleDC(lHdcRef)
' Libere le DC
ReleaseDC 0, lHdcRef
' Creation d'une nouvelle section DIB qui va contenir le bitmap
lhDIB = CreateDIBSection(lHdc, lBI, DIB_RGB_COLORS, lDIBPTR, 0, 0)
' On selectionne ce DIB dans le contexte d'affichage en prenant soin de conserver l'ancien DIB
lhOldDIB = SelectObject(lHdc, lhDIB)
' Brosse pour fond
If pIconBackColor < 0 Then OleTranslateColor pIconBackColor, 0, pIconBackColor
lBrush = CreateSolidBrush(pIconBackColor)
' Dessine l'icone sur le DIB
DrawIconEx lHdc, 0, 0, lIcon, lLoadhBmp.bmWidth, lLoadhBmp.bmHeight, 0, ByVal lBrush, &H3
' Lecture de la taille de l'image
Call apiGetObject(lhDIB, Len(lds), lds)
' Redimensionnement du tableau
ReDim lPicData(lds.dsBmih.biSizeImage + 40)
' Copie des donnees de l'image
RtlMoveMemory lPicData(40), ByVal lDIBPTR, lds.dsBmih.biSizeImage
' Copie des donnees en-tete
RtlMoveMemory lPicData(0), lds.dsBmih, 40
' Renvoie le resultat
GetIconPictureData = lPicData
Gestion_Erreurs:
If Err.Number <> 0 Then GetIconPictureData = Null
' Supprime les objets temporaire
DeleteObject lBrush
DeleteObject lpicinfo.hbmColor
DeleteObject lpicinfo.hbmMask
DestroyIcon lIcon
DeleteObject (SelectObject(lHdc, lhOldDIB))
DeleteDC lHdc
End Function |
