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
| Option Explicit
'-------------- utilisé par GDI+ et ole32 ---------
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 Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
'---------------- pour vérification disponibilité de GDI+ -----------
Public Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
'création d'un lien en mémoire pour la session d'utilisation GDI+
Public Declare Function GdiplusStartup Lib "gdiplus" _
(ByRef token As Long, inputbuf As GdiplusStartupInput, _
Optional ByVal outputbuf As Long = 0) As Long
'pour libération de la mémoire du lien session GDI+
Public Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
Dim ParamS As GdiplusStartupInput
Dim GDISess As Long 'variable conteneur du lien en mémoire pour la session d'utilisation GDI+
'création d'un Bitmap Gdi+ en mémoire, à partir d'un fichier
Public Declare Function GdipCreateBitmapFromFile Lib "gdiplus" _
(ByVal FileName As Long, ByRef BITMAP As Long) As Long
'pour libération de la mémoire du lien du Bitmap Gdi+
Public Declare Function GdipDisposeImage Lib "gdiplus" _
(ByVal image As Long) As Long
'sauvgarde d'une image GDI+, avec fonction encodage
Private Declare Function GdipSaveImageToFile Lib "gdiplus" ( _
ByVal image As Long, ByVal FileName As Long, clsidEncoder As GUID, _
encoderParams As Any) As Long
Public GDIBitmap As Long 'variable conteneur du Bitmap Gdi+
Public Sub Main()
''*****************************************************************
''*************Pour detecter si GDI+ sera disponnible *************
''*********** Impératif *******************************************
InitSessionGDI 'GDI+ est-il dispo ?*******************************
''********* Indispensable *****************************************
Form1.Show
End Sub
'-------------------------------------------------------------------------------------------
Private Sub InitSessionGDI()
ParamS.GdiplusVersion = 1
If GdiplusStartup(GDISess, ParamS) <> 0 Then
MsgBox "GDI+ non disponible"
End
End If
End Sub
Public Sub FinSessionGDI()
'nettoyage
If GDIBitmap <> 0 Then GdipDisposeImage GDIBitmap
GdiplusShutdown GDISess ' Ferme/supprime le lien d'utilisation de Gdi+
End Sub
'---------------------------------------------------------------------------------------
' Ouverture d'un fichier image
'---------------------------------------------------------------------------------------
Private Function OpenFile(ChemFich As String) As Boolean
' Création d'un Bitmap Gdi+ à partir du fichier image, si l'opération a réussi,
'renvoie 0, donc OpenFile = True, sinon renvoie un N° d'erreur donc False
OpenFile = (GdipCreateBitmapFromFile(StrPtr(ChemFich), GDIBitmap) = 0)
End Function
Public Function SaveFileImage(ChemFichierSource As String, _
Optional ChemFichierDest As String = "", _
Optional SupprimerSource As Boolean = False, _
Optional pFormat As String = "JPG", _
Optional ByVal pQuality As Integer = -1) As Boolean
If OpenFile(ChemFichierSource) <> True Then
MsgBox "Erreur recuperation de l'image source", vbCritical, ""
Exit Function
End If
If ChemFichierDest = "" Then
ChemFichierDest = Left(ChemFichierSource, Len(ChemFichierSource) - 3) & pFormat
End If
If UCase(Right(ChemFichierDest, 4)) <> "." & pFormat Then
ChemFichierDest = ChemFichierDest & "." & pFormat
End If
On Error GoTo Gestion_Erreur
Dim lEncoder As GUID
Dim lParams As EncoderParameters
Dim lEncoderStr As String
Const lBmpEncoderStr As String = "{557cf400-1a04-11d3-9a73-0000f81ef32e}"
Const lJpgEncoderStr As String = "{557cf401-1a04-11d3-9a73-0000f81ef32e}"
Const lGifEncoderStr As String = "{557cf402-1a04-11d3-9a73-0000f81ef32e}"
Const lTifEncoderStr As String = "{557cf405-1a04-11d3-9a73-0000f81ef32e}"
Const lPngEncoderStr As String = "{557cf406-1a04-11d3-9a73-0000f81ef32e}"
Const lQualityParamStr As String = "{1d5be4b5-fa4a-452d-9cdd-5db35105e7eb}"
' Format de l'encodeur
Select Case pFormat
Case "BMP": lEncoderStr = lBmpEncoderStr
Case "JPG": lEncoderStr = lJpgEncoderStr
Case "GIF": lEncoderStr = lGifEncoderStr 'image, pas animation
Case "TIF": lEncoderStr = lTifEncoderStr
Case "PNG": lEncoderStr = lPngEncoderStr
End Select
SaveFileImage = True 'Retour de la fonction, si tous se passe bien !!!!
' Recherche de l'encodeur Jpeg
CLSIDFromString StrPtr(lEncoderStr), lEncoder
If pQuality <> -1 And pFormat = "JPG" Then ' Paramètre de l'encodeur Jpeg
lParams.Count = 1
With lParams.Parameter(0)
' Paramètrage de la qualité (0-100)
'0 pas de compression qualité maxi, 100 compression maxi qualité mediocre
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
SaveFileImage = GdipSaveImageToFile(GDIBitmap, StrPtr(ChemFichierDest), lEncoder, lParams) = 0
Else
SaveFileImage = GdipSaveImageToFile(GDIBitmap, StrPtr(ChemFichierDest), lEncoder, Null) = 0
End If
GdipDisposeImage GDIBitmap 'libère la mémoire
If SupprimerSource = True Then Kill (ChemFichierSource)
Gestion_Erreur:
If Err.Number <> 0 Then SaveFileImage = False
End Function |
