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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
|
Option Compare Database
Option Explicit
'***************************************************************************************
'* CLASSE POUR UTILISATION DE GDIPLUS *
'***************************************************************************************
' Fonctionnalitées :
' Chargement d'images au format Jpeg/Gif/Png/Tiff/Bmp
' Rotation et retournement(mirroir) d'images
' Redimensionnement de l'image
' Découpage de l'image
' Décomposition des Gif animés
' Sauvegarde au format Jpeg/Gif/Png/Tiff/Bmp
' Affichage de l'image dans un contrôle image Access
'***************************************************************************************
' Auteur : Thierry GASPERMENT (Arkham46)
' v0.3 (08/11/06)
' Nécessite GDI+
' Le code est libre pour toute utilisation
'***************************************************************************************
'***************************************************************************************
'* LIENS *
'***************************************************************************************
' Téléchargement de GdiPlus.dll
' http://www.microsoft.com/downloads/details.aspx?FamilyID=6a63ab9c-df12-4d41-933c-be590feaa05a&DisplayLang=en
'***************************************************************************************
'* API *
'***************************************************************************************
' Gestion des dll
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
' API GDI+
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal FileName As Long, ByRef bitmap As Long) As Long
Private Declare Function GdipGetPropertyItem Lib "gdiplus" (ByVal image As Long, ByVal propId As Long, _
ByVal propSize As Long, ByRef buffer As Any) As Long
Private Declare Function GdipGetPropertyItemSize Lib "gdiplus" (ByVal image As Long, ByVal propId As Long, _
ByRef Size As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, LInput As GdiplusStartupInput, Optional ByVal lOutPut As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As Long, ByRef hbmReturn As Long, _
ByVal Background As Long) As Long
Private Declare Function GdipImageRotateFlip Lib "gdiplus" (ByVal image As Long, ByVal rfType As Long) As Long
Private Declare Function GdipImageSelectActiveFrame Lib "gdiplus" _
(ByVal image As Long, ByRef dimensionID As GUID, _
ByVal frameIndex As Long) As Long
Private Declare Function GdipImageGetFrameCount Lib "gdiplus" _
(ByVal image As Long, ByRef dimensionID As GUID, _
ByRef Count As Long) As Long
Private Declare Function GdipGetImageThumbnail Lib "gdiplus" _
(ByVal image As Long, ByVal thumbWidth As Long, _
ByVal thumbHeight As Long, ByRef thumbImage As Long, _
ByVal callback As Long, ByVal callbackData As Long) As Long
Private Declare Function GdipGetImageDimension Lib "gdiplus" _
(ByVal image As Long, ByRef Width As Single, _
ByRef Height As Single) As Long
Private Declare Function GdipCloneBitmapAreaI Lib "gdiplus" (ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal PixelFormat As Long, ByVal srcBitmap As Long, dstBitmap As Long) As Long
Private Declare Function GdipGetImagePixelFormat Lib "gdiplus" (ByVal image As Long, PixelFormat As Long) As Long
' Déplace une zone de mémoire
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal length As Long)
' API GDI
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal Hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal Hdc As Long, _
ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, _
ByVal ySrc As Long, ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function SetMapMode Lib "gdi32" (ByVal Hdc As Long, ByVal nMapMode As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd 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 Function SelectObject Lib "gdi32" (ByVal Hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function LPtoDP Lib "gdi32" (ByVal Hdc As Long, lpPoint As PointAPI, ByVal nCount As Long) As Long
Private Declare Function DPtoLP Lib "gdi32" (ByVal Hdc As Long, lpPoint As PointAPI, ByVal nCount 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 DeleteDC Lib "gdi32" (ByVal Hdc As Long) As Long
' Image EMF
Private Declare Function CreateEnhMetaFile Lib "gdi32" _
Alias "CreateEnhMetaFileA" _
(ByVal hdcRef As Long, _
ByVal lpFileName As String, _
ByRef lpRect As Any, _
ByVal lpDescription As String) As Long
Private Declare Function CloseEnhMetaFile Lib "gdi32" _
(ByVal Hdc As Long) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" _
(ByVal hemf As Long) As Long
Private Declare Function GetEnhMetaFileBits Lib "gdi32" _
(ByVal hemf As Long, ByVal cbBuffer As Long, lpbBuffer As Byte) As Long
'***************************************************************************************
'* Constantes *
'***************************************************************************************
Private Const MM_HIMETRIC = 3
Private Const MM_TEXT = 1
Private Const COLORONCOLOR = 3 ' Mode pour StretchBlt
Private Const SRCCOPY = &HCC0020
Private Const CF_ENHMETAFILE = 14
Private Const PropertyTagFrameDelay As Long = &H5100&
'***************************************************************************************
'* Types *
'***************************************************************************************
' Rectangle pour API
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' Type Point pour API
Private Type PointAPI
X As Long
Y As Long
End Type
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 PropertyItem
id As Long
length As Long
Type As Integer
Value As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
Type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter(15) As EncoderParameter
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
'***************************************************************************************
'* Variables *
'***************************************************************************************
Private gBitmap As Long
Private gBitmapWork As Long
Private gGdipToken As Long
Private gLib As Long
'***************************************************************************************
'* Propriétés / Enumérations *
'***************************************************************************************
#If VBA6 Then
Public Enum ERotateFlip
RotateNoneFlipNone = 0
Rotate90FlipNone = 1
Rotate180FlipNone = 2
Rotate270FlipNone = 3
RotateNoneFlipX = 4
Rotate90FlipX = 5
Rotate180FlipX = 6
Rotate270FlipX = 7
RotateNoneFlipY = Rotate180FlipX
Rotate90FlipY = Rotate270FlipX
Rotate180FlipY = RotateNoneFlipX
Rotate270FlipXY = Rotate90FlipNone
RotateNoneFlipXY = Rotate180FlipNone
Rotate90FlipXY = Rotate270FlipNone
Rotate180FlipXY = RotateNoneFlipNone
end enum
#Else
Property Get zRotate180FlipXY(): zRotate180FlipXY = zRotateNoneFlipNone: End Property
Property Get zRotate90FlipXY(): zRotate90FlipXY = zRotate270FlipNone: End Property
Property Get zRotateNoneFlipXY(): zRotateNoneFlipXY = zRotate180FlipNone: End Property
Property Get zRotate270FlipXY(): zRotate270FlipXY = zRotate90FlipNone: End Property
Property Get zRotate180FlipY(): zRotate180FlipY = zRotateNoneFlipX: End Property
Property Get zRotate90FlipY(): zRotate90FlipY = zRotate270FlipX: End Property
Property Get zRotateNoneFlipY(): zRotateNoneFlipY = zRotate180FlipX: End Property
Property Get zRotate270FlipX(): zRotate270FlipX = 7: End Property
Property Get zRotate180FlipX(): zRotate180FlipX = 6: End Property
Property Get zRotate90FlipX(): zRotate90FlipX = 5: End Property
Property Get zRotateNoneFlipX(): zRotateNoneFlipX = 4: End Property
Property Get zRotate270FlipNone(): zRotate270FlipNone = 3: End Property
Property Get zRotate180FlipNone(): zRotate180FlipNone = 2: End Property
Property Get zRotate90FlipNone(): zRotate90FlipNone = 1: End Property
Property Get zRotateNoneFlipNone(): zRotateNoneFlipNone = 0: End Property
#End If
'***************************************************************************************
'* FONCTIONS *
'***************************************************************************************
'---------------------------------------------------------------------------------------
' Propage l'erreur à l'appelant
'---------------------------------------------------------------------------------------
Private Sub ErrRaise()
Err.Raise Err.number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
'---------------------------------------------------------------------------------------
' Ouverture du fichier
'---------------------------------------------------------------------------------------
' pFile : Fichier
' pWidth, pHeight : Taille de l'image
' si une dimension de l'image est omise, elle est calculés pour conserver le ratio de l'image
' la taille de l'image chargée est renvoyée dans ces paramètres
' pSaveOriginal : mettre à vrai pour conserver l'image originale et pouvoir la rétablir
' après transformation (à l'aide de la fonction ResetImage
'---------------------------------------------------------------------------------------
Public Function OpenFile(pFile As String, Optional pWidth As Long = 0, Optional pHeight As Long = 0, Optional pSaveOriginal As Boolean) As Boolean
Dim lGdiPSI As GdiplusStartupInput
Dim lWidth As Single
Dim lHeight As Single
Dim lBitmap As Long
On Error GoTo Gestion_Erreur
' Fermeture d'un éventuel fichier déjà ouvert
CloseFile
' Retour de la fonction
OpenFile = True
' Initialisation GDI + version 1
lGdiPSI.GdiplusVersion = 1
If GdiplusStartup(gGdipToken, lGdiPSI) = 0 Then
' Création d'un Bitmap Gdi+ à partir du bitmap de l'image
OpenFile = (GdipCreateBitmapFromFile(StrPtr(pFile), gBitmap) = 0)
If OpenFile Then
GdipGetImageDimension gBitmap, lWidth, lHeight
If pWidth = 0 And pHeight = 0 Then 'Image complète
pWidth = lWidth
pHeight = lHeight
Else ' Image redimensionnée
If pWidth = 0 Then
pWidth = pHeight * lWidth / lHeight
ElseIf pHeight = 0 Then
pHeight = pWidth * lHeight / lWidth
End If
OpenFile = (GdipGetImageThumbnail(gBitmap, pWidth, pHeight, lBitmap, 0, 0) = 0)
GdipDisposeImage gBitmap
gBitmap = lBitmap
End If
End If
End If
Gestion_Erreur:
gBitmapWork = gBitmap
If Not pSaveOriginal Then gBitmap = 0
If Err.number <> 0 Then OpenFile = False
End Function
'---------------------------------------------------------------------------------------
' Fermeture du fichier
'---------------------------------------------------------------------------------------
Public Function CloseFile()
' Supprime le bitmap
If gBitmapWork <> gBitmap Then GdipDisposeImage gBitmapWork: gBitmapWork = gBitmap
If gBitmap <> 0 Then GdipDisposeImage gBitmap: gBitmap = 0
' Ferme Gdi+
If gGdipToken <> 0 Then GdiplusShutdown gGdipToken: gGdipToken = 0
End Function
'---------------------------------------------------------------------------------------
' Sauvegarde le fichier
'---------------------------------------------------------------------------------------
' pFile : Fichier
' pFormat : format du fichier : JPG,GIF,BMP,PNG,TIF
' pQuality : Qualité Jpeg (0-100)
'---------------------------------------------------------------------------------------
Public Function SaveFile(pFile As String, Optional pFormat As String = "JPG", Optional ByVal pQuality As Integer = -1) As Boolean
Dim lEncoder As GUID
Dim lParams As EncoderParameters
Dim lEncoderStr As String
Const lJpegEncoderStr As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Const lGifEncoderStr As String = "{557cf402-1a04-11d3-9a73-0000f81ef32e}"
Const lBmpEncoderStr As String = "{557cf400-1a04-11d3-9a73-0000f81ef32e}"
Const lPngEncoderStr As String = "{557cf406-1a04-11d3-9a73-0000f81ef32e}"
Const lTifEncoderStr As String = "{557cf405-1a04-11d3-9a73-0000f81ef32e}"
Const lQualityParamStr As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
On Error GoTo Gestion_Erreur
' Format de l'encodeur
Select Case pFormat
Case "JPG"
lEncoderStr = lJpegEncoderStr
Case "GIF"
lEncoderStr = lGifEncoderStr
Case "BMP"
lEncoderStr = lBmpEncoderStr
Case "PNG"
lEncoderStr = lPngEncoderStr
Case "TIF"
lEncoderStr = lTifEncoderStr
End Select
SaveFile = True
' Recherche de l'encodeur Jpeg
CLSIDFromString StrPtr(lEncoderStr), lEncoder
' Paramètre de l'encodeur Jpeg
If pQuality <> -1 And pFormat = "JPG" Then
lParams.Count = 1
With lParams.Parameter(0)
' Paramètrage de la qualité (0-100)
CLSIDFromString StrPtr(lQualityParamStr), .GUID
.NumberOfValues = 1
.Type = 4 ' Type Long
.Value = VarPtr(pQuality)
End With
End If
' Sauvegarde l'image
If lParams.Count > 0 Then
SaveFile = (GdipSaveImageToFile(gBitmapWork, StrPtr(pFile), lEncoder, lParams) = 0)
Else
SaveFile = (GdipSaveImageToFile(gBitmapWork, StrPtr(pFile), lEncoder, Null) = 0)
End If
Gestion_Erreur:
If Err.number <> 0 Then SaveFile = False
End Function
'---------------------------------------------------------------------------------------
' Initialisation de la classe
'---------------------------------------------------------------------------------------
Private Sub Class_Initialize()
' Charge la librarie gdiplus
gLib = LoadLibrary(ApplicationPath & "gdiplus.dll")
End Sub
'---------------------------------------------------------------------------------------
' Libération de la classe
'---------------------------------------------------------------------------------------
Private Sub Class_Terminate()
' Ferme un éventuel fichier ouvert
CloseFile
End Sub
'---------------------------------------------------------------------------------------
' Transfère les données du Bitmap dans un tableau de type PictureData
'---------------------------------------------------------------------------------------
' phDIB : Objet Bitmap
' On utilise un objet EMF car Access gère très mal les redimensionnements des Bitmaps
'---------------------------------------------------------------------------------------
Private Function DIBtoPictureData(phDIB As Long) As Variant
Dim lhMeta As Long
Dim lhMetaFile As Long
Dim lhdcref As Long
Dim lrect As Rect
Dim lngret As Long
Dim pt As PointAPI
Dim lds As DIBSECTION
Dim lhDC As Long
Dim lOldBmp As Long
Dim lPicData() As Byte
On Error GoTo Gestion_Erreurs:
' Relecture de la taille de l'image
Call apiGetObject(phDIB, Len(lds), lds)
' Récupère la taille en données de type OLE_Himetric pour la création de l'EMF
pt.X = lds.dsBmih.biWidth
pt.Y = lds.dsBmih.biHeight
lhdcref = GetDC(0) ' Device contexte temporaire
lngret = SetMapMode(lhdcref, MM_HIMETRIC)
DPtoLP lhdcref, pt, 1
' Rectangle pour création de l'EMF
lrect.Right = pt.X
lrect.Bottom = Abs(pt.Y)
' Conversion de la taille en pixels
LPtoDP lhdcref, pt, 1
pt.Y = Abs(pt.Y)
SetMapMode lhdcref, lngret
' Création d'un contexte d'affichage EMF
lhMeta = CreateEnhMetaFile(lhdcref, vbNullString, lrect, vbNullString)
' Coordonnées en pixels
lngret = SetMapMode(lhMeta, MM_TEXT)
' Type de redimensionnement
lngret = SetStretchBltMode(lhMeta, COLORONCOLOR)
' Crée un contexte d'affichage temporaire
lhDC = CreateCompatibleDC(0)
' Affecte le bitmap au DC temporaire
lOldBmp = SelectObject(lhDC, phDIB)
' Copie de l'image dans le MetaFile
StretchBlt lhMeta, 0, 0, pt.X, pt.Y, lhDC, 0, 0, lds.dsBmih.biWidth, lds.dsBmih.biHeight, SRCCOPY
' Ferme le contexte d'affichage et récupère le MetaFile
lhMetaFile = CloseEnhMetaFile(lhMeta)
' Récupère la taille des données Méta
lngret = GetEnhMetaFileBits(lhMetaFile, 0, ByVal 0&)
' Redimensionne le tableau de données
ReDim lPicData((lngret - 1) + 8)
' Récupère les données dans le tableau
lngret = GetEnhMetaFileBits(lhMetaFile, lngret, lPicData(8))
' Supprime le MétaFile
lngret = DeleteEnhMetaFile(lhMetaFile)
' Type de l'image dans le tableau de données
lPicData(0) = CF_ENHMETAFILE
' Libère le device contexte de travail
ReleaseDC 0&, lhdcref
' Supprime le DC
DeleteObject SelectObject(lhDC, lOldBmp)
DeleteDC lhDC
' Renvoie le résultat
DIBtoPictureData = lPicData
Gestion_Erreurs:
If Err.number <> 0 Then DIBtoPictureData = Null ' Renvoie Null si erreur
End Function
'---------------------------------------------------------------------------------------
' Chemin de l'application
'---------------------------------------------------------------------------------------
' Utile pour access97 : currentproject.path n'existe pas
'---------------------------------------------------------------------------------------
Private Function ApplicationPath() As String
ApplicationPath = Left(CurrentDb.Name, Len(CurrentDb.Name) - Len(Dir(CurrentDb.Name)))
End Function
'---------------------------------------------------------------------------------------
' Récupère un tableau PictureData pour contrôle image Access
'---------------------------------------------------------------------------------------
Public Function GdiPlusToPictureData() As Variant
Dim lBitmapGdi As Long
' Transformation du bitmap GDI+ en bitmap Gdi "classique"
Call GdipCreateHBITMAPFromBitmap(gBitmapWork, lBitmapGdi, 0)
' Retour de la fonction = tableau de byte affectable à une propriété PictureData
GdiPlusToPictureData = DIBtoPictureData(lBitmapGdi)
' Suppression du bitmap GDI
DeleteObject lBitmapGdi
End Function
'---------------------------------------------------------------------------------------
' Change l'image courante d'un gif animé
' pFrame : numéro de l'image
'---------------------------------------------------------------------------------------
Public Function GifSetFrame(pFrame As Long)
Dim lFDTGUID As GUID
Const lFrameDimensionTime As String = "{6AEDBD6D-3FB5-418A-83A6-7F45229DC872}"
Call CLSIDFromString(StrPtr(lFrameDimensionTime), lFDTGUID)
GdipImageSelectActiveFrame gBitmapWork, lFDTGUID, pFrame
End Function
'---------------------------------------------------------------------------------------
' Nombre d'images d'un gif animé
'---------------------------------------------------------------------------------------
Public Function GifGetFrameCount() As Long
Dim lFDTGUID As GUID
Const lFrameDimensionTime As String = "{6AEDBD6D-3FB5-418A-83A6-7F45229DC872}"
Call CLSIDFromString(StrPtr(lFrameDimensionTime), lFDTGUID)
GdipImageGetFrameCount gBitmapWork, lFDTGUID, GifGetFrameCount
End Function
'---------------------------------------------------------------------------------------
' Delais d'affichage des images d'un gif animé
' Renvoit un tableau contenant autant de délais que d'images dans le gif
'---------------------------------------------------------------------------------------
Public Function GifGetFrameDelay() As Variant
Dim lPropSize As Long
Dim lBuffer() As Byte
Dim lPropertyItem As PropertyItem
Dim lResultLong() As Long
Dim lFrameCount As Long
Dim lcpt As Long
If GdipGetPropertyItemSize(gBitmapWork, PropertyTagFrameDelay, lPropSize) = 0 Then
ReDim lBuffer(lPropSize - 1)
If GdipGetPropertyItem(gBitmapWork, PropertyTagFrameDelay, lPropSize, lBuffer(0)) = 0 Then
Call RtlMoveMemory(lPropertyItem, lBuffer(0), LenB(lPropertyItem))
If lPropertyItem.length > 0 Then
' On déplace la valeur dans un tableau (tPropertyItem.Value est un pointeur)
ReDim lReturnBuffer(lPropertyItem.length - 1)
Call RtlMoveMemory(lReturnBuffer(0), _
ByVal lPropertyItem.Value, _
lPropertyItem.length)
' Pour chaque image, le delai est stocké dans un Long, donc taille = 4
ReDim lResultLong(lPropertyItem.length / 4 - 1)
RtlMoveMemory lResultLong(0), lReturnBuffer(0), lPropertyItem.length
GifGetFrameDelay = lResultLong
End If
End If
End If
End Function
'---------------------------------------------------------------------------------------
' Rotation/Miroir de l'image
' pType : type de transformation
'---------------------------------------------------------------------------------------
#If VBA6 Then
Public Function RotateFlip(pType As ERotateFlip)
#Else
Public Function RotateFlip(pType As Long)
#End If
Dim lWidth As Single
Dim lHeight As Single
Dim lPixelFormat As Long
Dim lNewBitmap As Long
GdipGetImageDimension gBitmapWork, lWidth, lHeight
lPixelFormat = GdipGetImagePixelFormat(gBitmapWork, lPixelFormat)
GdipCloneBitmapAreaI 0, 0, lWidth, lHeight, lPixelFormat, gBitmapWork, lNewBitmap
Call GdipImageRotateFlip(lNewBitmap, pType)
If gBitmapWork <> gBitmap Then GdipDisposeImage gBitmapWork
gBitmapWork = lNewBitmap
End Function
'---------------------------------------------------------------------------------------
' Redimensionne l'image
'---------------------------------------------------------------------------------------
' pWidth : Largeur
' pHeight : Hauteur
'---------------------------------------------------------------------------------------
Public Function ResizeImage(Optional pWidth As Long = 0, Optional pHeight As Long = 0) As Boolean
Dim lWidth As Single
Dim lHeight As Single
Dim lNewBitmap As Long
ResizeImage = False
GdipGetImageDimension gBitmapWork, lWidth, lHeight
If pWidth = 0 And pHeight = 0 Then
pWidth = lWidth
pHeight = lHeight
Else
If pWidth = 0 Then
pWidth = pHeight * lWidth / lHeight
ElseIf pHeight = 0 Then
pHeight = pWidth * lHeight / lWidth
End If
ResizeImage = (GdipGetImageThumbnail(gBitmapWork, pWidth, pHeight, lNewBitmap, 0, 0) = 0)
If gBitmapWork <> gBitmap Then GdipDisposeImage gBitmapWork
gBitmapWork = lNewBitmap
End If
End Function
'---------------------------------------------------------------------------------------
' Découpe l'image
'---------------------------------------------------------------------------------------
' pLeft : Position à gauche
' pTop : Position en haut
' pWidth : Largeur
' pHeight : Hauteur
'---------------------------------------------------------------------------------------
Public Function CropImage(Optional pLeft As Long = 0, Optional pTop As Long = 0, Optional pWidth = 0, Optional pHeight = 0) As Boolean
Dim lWidth As Single
Dim lHeight As Single
Dim lPixelFormat As Long
Dim lNewBitmap As Long
CropImage = False
GdipGetImageDimension gBitmapWork, lWidth, lHeight
If pWidth <> 0 Then lWidth = pWidth
If pHeight <> 0 Then lHeight = pHeight
lPixelFormat = GdipGetImagePixelFormat(gBitmapWork, lPixelFormat)
CropImage = (GdipCloneBitmapAreaI(pLeft, pTop, lWidth, lHeight, lPixelFormat, gBitmapWork, lNewBitmap) = 0)
If gBitmapWork <> gBitmap Then GdipDisposeImage gBitmapWork
gBitmapWork = lNewBitmap
End Function
'---------------------------------------------------------------------------------------
' Rétablit l'image d'origine
'---------------------------------------------------------------------------------------
Public Function ResetImage()
If gBitmapWork <> gBitmap Then GdipDisposeImage gBitmapWork
gBitmapWork = gBitmap
End Function |
11/09/2006, 14h01
GdiPlus : Rotation/Redimensionnement/Découpage image + Gif animé
00
