Créer une miniature d'un png/tiff/ico/bmp/jpg/gif en un seul module

Commenter

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.

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

S'inscrire maintenant

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.

Du même auteur (cs_kroman)