0/5 (6 avis)
Snippet vu 14 088 fois - Téléchargée 22 fois
'=========== '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
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.