'// à mettre dans un Module
Public Enum GpStatus
Ok = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
End Enum
Public Enum EncoderParameterValueType
EncoderParameterValueTypeByte = 1
EncoderParameterValueTypeASCII = 2
EncoderParameterValueTypeShort = 3
EncoderParameterValueTypeLong = 4
EncoderParameterValueTypeRational = 5
EncoderParameterValueTypeLongRange = 6
EncoderParameterValueTypeUndefined = 7
EncoderParameterValueTypeRationalRange = 8
End Enum
Public Enum ImageCodecFlags
ImageCodecFlagsEncoder = &H1
ImageCodecFlagsDecoder = &H2
ImageCodecFlagsSupportBitmap = &H4
ImageCodecFlagsSupportVector = &H8
ImageCodecFlagsSeekableEncode = &H10
ImageCodecFlagsBlockingDecode = &H20
ImageCodecFlagsBuiltin = &H10000
ImageCodecFlagsSystem = &H20000
ImageCodecFlagsUser = &H40000
End Enum
Public Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Public Type CLSID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Public Type ImageCodecInfo
ClassID As CLSID
FormatID As CLSID
CodecName As Long
DllName As Long
FormatDescription As Long
FilenameExtension As Long
MimeType As Long
flags As ImageCodecFlags
Version As Long
SigCount As Long
SigSize As Long
SigPattern As Long
SigMask As Long
End Type
Public Type EncoderParameter
GUID As CLSID
NumberOfValues As Long
type As EncoderParameterValueType
value As Long
End Type
Public Type EncoderParameters
count As Long
Parameter As EncoderParameter
End Type
Public Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Public Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Public Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
Public Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, image As Long) As GpStatus
Public Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal filename As String, clsidEncoder As CLSID, encoderParams As Any) As GpStatus
Public Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, size As Long) As GpStatus
Public Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal size As Long, encoders As Any) As GpStatus
Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal psString As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpszProgID As Long, pCLSID As CLSID) As Long
Public Function GetEncoderClsid(strMimeType As String, ClassID As CLSID)
Dim num As Long
Dim size As Long
Dim I As Long
Dim ICI() As ImageCodecInfo
Dim buffer() As Byte
GetEncoderClsid = -1
Call GdipGetImageEncodersSize(num, size)
If size = 0 Then Exit Function
ReDim ICI(1 To num)
ReDim buffer(1 To size)
Call GdipGetImageEncoders(num, size, buffer(1))
Call CopyMemory(ICI(1), buffer(1), (Len(ICI(1)) * num))
For I = 1 To num
If StrComp(PtrToStrW(ICI(I).MimeType), strMimeType, vbTextCompare) = 0 Then
ClassID = ICI(I).ClassID
GetEncoderClsid = I
Exit For
End If
Next
Erase ICI
Erase buffer
End Function
Public Function PtrToStrW(ByVal lpsz As Long) As String
Dim sOut As String
Dim lLen As Long
lLen = lstrlenW(lpsz)
If (lLen > 0) Then
sOut = StrConv(String$(lLen, vbNullChar), vbUnicode)
Call CopyMemory(ByVal sOut, ByVal lpsz, lLen * 2)
PtrToStrW = StrConv(sOut, vbFromUnicode)
End If
End Function
Public Function DEFINE_GUID(ByVal sGuid As String) As CLSID
Call CLSIDFromString(StrPtr(sGuid), DEFINE_GUID)
End Function
'// à mettre sur une Forme
Dim token As Long
Dim img As Long
Dim encoderCLSID As CLSID
Dim stat As GpStatus
Private Sub Form_Load()
Dim GpInput As GdiplusStartupInput
GpInput.GdiplusVersion = 1
If GdiplusStartup(token, GpInput) <> Ok Then
MsgBox "Erreur chargement GDI+!", vbCritical
Unload Me
End If
End Sub
Private Sub ConvertImage(Source As String, Destination As String, MimeType As Integer, Optional Quality As Integer = 75)
Dim encoderParams As EncoderParameters
Dim lngQuality As Long
Dim strMimeType As String
Call GdipLoadImageFromFile(StrConv(Source, vbUnicode), img)
If MimeType = 1 Then strMimeType = "image/bmp"
If MimeType = 2 Then strMimeType = "image/jpeg"
If MimeType = 3 Then strMimeType = "image/png"
Call GetEncoderClsid(strMimeType, encoderCLSID)
If MimeType = 2 Then
If Quality < 0 Or Quality > 100 Then
lngQuality = 75
Else
lngQuality = Quality
End If
encoderParams.count = 1
With encoderParams.Parameter
.NumberOfValues = 1
.type = EncoderParameterValueTypeLong
.GUID = DEFINE_GUID(EncoderQuality)
.value = VarPtr(lngQuality)
End With
stat = GdipSaveImageToFile(img, StrConv(Destination, vbUnicode), encoderCLSID, encoderParams)
Else
stat = GdipSaveImageToFile(img, StrConv(Destination, vbUnicode), encoderCLSID, ByVal 0)
End If
Call GdipDisposeImage(img)
If stat = Ok Then
MsgBox "la conversion s'est terminée avec succès !", vbInformation
Else
MsgBox "il y a eu erreur pendant la conversion ! Status Code= " & stat, vbCritical
End If
End Sub
Private Sub JPGtoBMP(Source As String, Destination As String)
Call ConvertImage(Source, Destination, 1)
End Sub
Private Sub PNGtoBMP(Source As String, Destination As String)
Call ConvertImage(Source, Destination, 1)
End Sub
Private Sub BMPtoJPG(Source As String, Destination As String, Quality As Integer)
Call ConvertImage(Source, Destination, 2, Quality)
End Sub
Private Sub PNGtoJPG(Source As String, Destination As String, Quality As Integer)
Call ConvertImage(Source, Destination, 2, Quality)
End Sub
Private Sub BMPtoPNG(Source As String, Destination As String)
Call ConvertImage(Source, Destination, 3)
End Sub
Private Sub JPGtoPNG(Source As String, Destination As String)
Call ConvertImage(Source, Destination, 3)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call GdiplusShutdown(token)
End Sub
'// les conversions possible:
' Call BMPtoJPG(chemin_image_source.bmp, chemin_image_destination.jpg, 90)
' Call BMPtoPNG(chemin_image_source.bmp, chemin_image_destination.png)
' Call PNGtoJPG(chemin_image_source.png, chemin_image_destination.jpg, 90)
' Call PNGtoBMP(chemin_image_source.png, chemin_image_destination.bmp)
' Call JPGtoBMP(chemin_image_source.jpg, chemin_image_destination.bmp)
' Call JPGtoPNG(chemin_image_source.jpg, chemin_image_destination.png)