Créer une miniature d'un png/tiff/ico/bmp/jpg/gif en un seul module
0/5 (6 avis)
Snippet vu 14 088 fois - Téléchargée 22 fois
Contenu du snippet
Voici un petit bout de code permettant de créer des miniatures à partir d'une image de n'importe quel format.
Ce code ne tient qu'en un seul module (pas d'OCX ou de control) !! Il utilise la bibliothèque "GDI+".
Les avantages sont:
- La prise en charge des formats PNG/ICO/TIFF (d'ailleurs la miniature est enregistrée au format PNG).
- La prise en charge de la transparence PNG.
- Une exécution très rapide (plus rapide qu'en utilisant des contrôles 'picturebox').
- Une gestion de l'antialiasing pour le redimentionnent de la miniature.
Ce code ne tient qu'en un seul module (pas d'OCX ou de control) !! Il utilise la bibliothèque "GDI+".
Les avantages sont:
- La prise en charge des formats PNG/ICO/TIFF (d'ailleurs la miniature est enregistrée au format PNG).
- La prise en charge de la transparence PNG.
- Une exécution très rapide (plus rapide qu'en utilisant des contrôles 'picturebox').
- Une gestion de l'antialiasing pour le redimentionnent de la miniature.
Source / Exemple :
'===========
'Code option
'===========
Option Explicit
'===================
'Variables du module
'===================
Private lngHGdiPlus As Long
Private udtPngClsid As UUID
Private Const THUMB_DIM As Integer = 96 'Pixel
Private Const OUTPUT_FORMAT As String = "image/png" 'Mime type
'====
'APIs
'====
'General
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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
'Gdi plus : start / stop
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
'Gdi plus : object creation
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus.dll" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, nBitmap As Long) As GpStatus
'Gdi plus : load / save
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, ByRef image As Long) As GpStatus
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal filename As String, clsidEncoder As UUID, encoderParams As Any) As GpStatus
'Gdi plus : dispose
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
'Gdi plus : get
Private Declare Function GdipGetImageThumbnail Lib "gdiplus" (ByVal pImage As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, ByRef thumbImage As Long, ByVal pcallback As Long, ByVal callbackData As Long) As GpStatus
Private Declare Function GdipGetImageDimension Lib "gdiplus" (ByVal image As Long, ByRef width As Single, ByRef Height As Single) As GpStatus
Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, size As Long) As GpStatus
Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal size As Long, encoders As Any) As GpStatus
Private Declare Function GdipGetImagePixelFormat Lib "gdiplus" (ByVal nImage As Long, PixelFormat As Long) As Long
'============
'Types & enum
'============
Private Enum GpStatus
Gp_Ok = 0
Gp_GenericError = 1
Gp_InvalidParameter = 2
Gp_OutOfMemory = 3
Gp_ObjectBusy = 4
Gp_InsufficientBuffer = 5
Gp_NotImplemented = 6
Gp_Win32Error = 7
Gp_WrongState = 8
Gp_Aborted = 9
Gp_FileNotFound = 10
Gp_ValueOverflow = 11
Gp_AccessDenied = 12
Gp_UnknownImageFormat = 13
Gp_FontFamilyNotFound = 14
Gp_FontStyleNotFound = 15
Gp_NotTrueTypeFont = 16
Gp_UnsupportedGdiplusVersion = 17
Gp_GdiplusNotInitialized = 18
Gp_PropertyNotFound = 19
Gp_PropertyNotSupported = 20
End Enum
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Public Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type ImageCodecInfo
ClassID As UUID
FormatID As UUID
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
Private Enum ImageCodecFlags
ImageCodecFlagsEncoder = &H1
ImageCodecFlagsDecoder = &H2
ImageCodecFlagsSupportBitmap = &H4
ImageCodecFlagsSupportVector = &H8
ImageCodecFlagsSeekableEncode = &H10
ImageCodecFlagsBlockingDecode = &H20
ImageCodecFlagsBuiltin = &H10000
ImageCodecFlagsSystem = &H20000
ImageCodecFlagsUser = &H40000
End Enum
'========
'Main sub
'========
Private Sub Main()
'Declaration
Dim strImagePath As String
Dim strThumbPath As String
'Test si gdiplus.dll peut être invoqué sur le système
If IsDllExist("gdiplus") = False Then
MsgBox "GDI+ loading failed", vbCritical
End
End If
'Chemins
strImagePath = "c:\image.png" 'Image source
strThumbPath = "c:\thumb.png" 'Miniature
'Démarre GDI+
StartGdiPlus
'Récupère le CLSID de l'encoder 'PNG'
GetEncoderClsid OUTPUT_FORMAT, udtPngClsid
'Tente de créer la miniature
If CreateThumbnail(strImagePath, strThumbPath, THUMB_DIM) = True Then
MsgBox "Thumbnail created with success : " & strThumbPath, vbInformation
Else
MsgBox "Thumbnail creation failed : " & strThumbPath, vbCritical
End If
'Stop GDI+
StopGdiPlus
End Sub
'============
'Démarre Gdi+
'============
Public Sub StartGdiPlus()
'Déclarations
Dim lpSI As GdiplusStartupInput
'Initialise les paramètres de Gdi plus
lpSI.GdiplusVersion = 1
'Démarre Gdi plus
GdiplusStartup lngHGdiPlus, lpSI
End Sub
'=========
'Stop Gdi+
'=========
Public Sub StopGdiPlus()
'Stop GDI+
GdiplusShutdown lngHGdiPlus
End Sub
'================================
'Créé une miniature au format PNG
'================================
Public Function CreateThumbnail(ByRef ImagePath As String, ByRef ThumbnailPath As String, ThumbnailDim As Integer) As Boolean
'Déclarations
Dim hImage As Long
Dim hThumbnail As Long
Dim nImageWidth As Single
Dim nImageHeight As Single
Dim nThumbnailWidth As Single
Dim nThumbnailHeight As Single
Dim lPixelFormat As Long
'Charge l'image source
If GdipLoadImageFromFile(StrConv(ImagePath, vbUnicode), hImage) = Gp_Ok Then
'Récupère ses dimensions
If GdipGetImageDimension(hImage, nImageWidth, nImageHeight) = Gp_Ok Then
'Défini les dimensions de la miniature
If ThumbnailDim >= nImageWidth And ThumbnailDim >= nImageHeight Then
nThumbnailWidth = nImageWidth
nThumbnailHeight = nImageHeight
ElseIf nImageWidth = nImageHeight Then
nThumbnailWidth = ThumbnailDim
nThumbnailHeight = ThumbnailDim
ElseIf nImageWidth > nImageHeight Then
nThumbnailWidth = ThumbnailDim
nThumbnailHeight = Round(nImageHeight * (ThumbnailDim / nImageWidth))
ElseIf nImageHeight > nImageWidth Then
nThumbnailWidth = Round(nImageWidth * (ThumbnailDim / nImageHeight))
nThumbnailHeight = ThumbnailDim
End If
'Récupère le format
GdipGetImagePixelFormat hImage, lPixelFormat
'Créé l'objet 'image' pour la miniature
If GdipCreateBitmapFromScan0(nThumbnailWidth, nThumbnailHeight, 0, lPixelFormat, ByVal 0&, hThumbnail) = Gp_Ok Then
'Copie l'image redimentionnée vers l'image de destination
If GdipGetImageThumbnail(hImage, nThumbnailWidth, nThumbnailHeight, hThumbnail, ByVal 0&, ByVal 0&) = Gp_Ok Then
'Sauvegarde la miniature sur le disque
If GdipSaveImageToFile(hThumbnail, StrConv(ThumbnailPath, vbUnicode), udtPngClsid, ByVal 0) = Gp_Ok Then
'Arrivé ici, la fonction n'a pas échoué!
CreateThumbnail = True
End If
End If
'Détruit l'objet 'image' de la miniature
GdipDisposeImage hThumbnail
End If
End If
'Détruit l'objet 'image' de la source
GdipDisposeImage hImage
End If
End Function
'=======================================================
'GetEncoderClsid passe en revue les encoder disponibles
'sur le système. Si il tombe sur celui dont le mime
'type est égal au mime type stocké dans la variable
'strMimeType, il récupère son CLSID et celui-ci sera
'utilisé' par GdipSaveImageToFile.
'=======================================================
Public Function GetEncoderClsid(strMimeType As String, ClassID As UUID) As Long
'Déclarations
Dim num As Long
Dim size As Long
Dim i As Long
Dim ICI() As ImageCodecInfo
Dim buffer() As Byte
'Initie la valeur de retour
GetEncoderClsid = -1
'Récupère les infos des encoders du système
Call GdipGetImageEncodersSize(num, size)
'Aucun encoder trouvé : quitte la fonction
If size = 0 Then Exit Function
'Initie la taille des buffers
ReDim ICI(1 To num)
ReDim buffer(1 To size)
'Rempli les buffers avec les caractéristiques des encoders
Call GdipGetImageEncoders(num, size, buffer(1))
Call CopyMemory(ICI(1), buffer(1), (Len(ICI(1)) * num))
'Passe en revue la liste des encoders trouvés
For i = 1 To num
'Test si le mime type de l'encoder correspond à celui désiré
If StrComp(PtrToStrW(ICI(i).MimeType), strMimeType, vbTextCompare) = 0 Then
'Encoder trouvé : retourne sa ClassID et quitte la boucle
ClassID = ICI(i).ClassID
GetEncoderClsid = i
Exit For
End If
Next
'Détruit les buffers
Erase ICI
Erase buffer
End Function
'=============================
'Converti un pointer en chaine
'=============================
Public Function PtrToStrW(ByVal lpsz As Long) As String
'Déclarations
Dim sOut As String
Dim lLen As Long
'Récupère la taille de la chaine
lLen = lstrlenW(lpsz)
'Si la taille n'est pas nulle
If (lLen > 0) Then
'Retourne le résultat sous la forme d'une chaine
sOut = StrConv(String$(lLen, vbNullChar), vbUnicode)
Call CopyMemory(ByVal sOut, ByVal lpsz, lLen * 2)
PtrToStrW = StrConv(sOut, vbFromUnicode)
End If
End Function
'==================================
'Test si une dll peut être invoquée
'==================================
Public Function IsDllExist(name As String) As Boolean
'Déclarations
Dim lngHLib As Long
'Tente de charger la dll
lngHLib = LoadLibrary(name)
'Si la dll a été chargée
If lngHLib <> 0 Then
'Décharge la dll & retourne 'true'
FreeLibrary lngHLib
IsDllExist = True
End If
End Function
A voir également
- Créer une miniature d'un png/tiff/ico/bmp/jpg/gif en un seul module
- Tiff to jpg ✓ - Forum C# / .NET
- Convertir png en bmp - Forum C / C++ / C++.NET
- Effet miniature png - Conseils pratiques -PHP
- Png to jpg ✓ - Forum Delphi / Pascal
- Recuperer miniature ✓ - Forum PHP
29 janv. 2008 à 14:20
28 janv. 2008 à 08:26
ça à l'air intéressant une question cependant la source est elle adaptable au macros d' Excel
je pense notamment à la sauvegarde d'image crées dans excel avec l'outil de dessin :image d'entête ou de Logos
Cordialement
Daranc
24 janv. 2008 à 23:35
24 janv. 2008 à 21:51
24 janv. 2008 à 18:40
Copier/coller d'une source existante : Http explorer 1.07 (mon autre source), un serveur web multilingue diffusé sur vbfrance & sourceforge (et donc complètement codé en anglais) qui créé des miniatures dans les pages index :p
Un exemple ici : http://http-explorer.sourceforge.net/images/screenshots/full_15.png
La version actuelle de ce projet (1.06) sur vbfrance utilise un procédé assez "sale" (chargement de l'image dans une picturebox, copie de cette image redimensionné dans une autre picturebox, enregistrement du résultat avec SavePicture, le tout dans un usercontrol) avec le désagrément de ne pas supporter le PNG.
J'ai cherché une solution ces derniers jours et je suis tombé sur cette super source :
http://www.vbfrance.com/codes/IMAGE-PNG-COMME-SPLASHSCREEN-FAUX-TRANSPARENT_44107.aspx
Ce n'était pas du tout ce que je cherchais mais ça ma permis de me mettre au GDI+ et j'ai pu créé ce code qui sera intégré dans la prochaine version de mon serveur :)
J'en ai donc aussi profité pour le faire tenir dans un seul module et le partager ici.
Pour les variables & commentaires inutiles peux-tu développer?
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.