Mit nachfolgender Funktion lässt sich ein Vorschaubild aus einer Bilddatei erstellen, wobei man neben der Bilddatei selbst noch die Wunschgröße angeben kann. Da die Funktionen auf das GDI+ API von Windows zurückgreift, werden neben dem BMP, GIF und JPFG-Format auch das weitverbreitete PNG-Format unterstützt. Damit das Vorschaubild nicht "verzerrt" angezeigt wird, berücksichtigt die Funktion automatisch auch das korrekte Seitenverhältnis, d.h. die tatsächliche Höhe bzw. Breite des Vorschaubildes kann durchaus von der "Wunschgröße" abweichen. Packen Sie nachfolgenden Code in ein Modul. Option Explicit ' benötigte API-Deklarationen Private Type GdiplusStartupInput GdiplusVersion As Long DebugEventCallback As Long SuppressBackgroundThread As Long SuppressExternalCodecs As Long End Type Private Declare Function GdiplusStartup Lib "GDIPlus" ( _ Token As Long, _ InputBuf As GdiplusStartupInput, _ Optional ByVal OutputBuf As Long = 0) As Long Private Declare Function GdiplusShutdown Lib "GDIPlus" ( _ ByVal Token As Long) As Long Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" ( _ ByVal Filename As Long, _ hBitmap As Long) As Long Private Declare Function GdipGetImageDimension Lib "GDIPlus" ( _ ByVal hImage As Long, _ Width As Single, _ Height As Single) As Long Private Declare Function GdipGetImageThumbnail Lib "GDIPlus" ( _ ByVal hImage As Long, _ ByVal thumbWidth As Long, _ ByVal thumbHeight As Long, _ thumbImage As Long, _ ByVal callback As Long, _ ByVal callbackData As Long) As Long Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" ( _ ByVal hBitmap As Long, _ hbmReturn As Long, _ ByVal Background As Long) As Long Private Declare Function GdipDisposeImage Lib "GDIPlus" ( _ ByVal hImage As Long) As Long Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _ lpPictDesc As PictDesc, _ riid As Any, _ ByVal fOwn As Long, _ lplpvObj As IPicture) As Long Private Type PictDesc cbSizeofStruct As Long picType As Long hImage As Long xExt As Long yExt As Long End Type ' Erstellt ein Vorschaubild aus der angegeben Bilddatei in der gewünschten Größe ' unter Berücksichtigung des korrekten Seitenverhältnisses Public Function CreateThumbnail(ByVal File As String, _ ByVal MaxWidth As Long, ByVal MaxHeight As Long) As StdPicture Dim SI As GdiplusStartupInput Dim hBitmap As Long Dim Token As Long Dim Width As Single Dim Height As Single Dim nPercent As Long Dim hThumb As Long Dim hDestBitmap As Long Set CreateThumbnail = Nothing ' GDI+ initialisieren SI.GdiplusVersion = 1 If GdiplusStartup(Token, SI) = 0 Then ' Bilddatei erstellen If GdipCreateBitmapFromFile(StrPtr(File), hBitmap) = 0 Then ' Originalgröße des Bilder ermitteln If GdipGetImageDimension(hBitmap, Width, Height) = 0 Then ' Vorschaugröße im korrekten Seitenverhältnis ermitteln nPercent = (MaxWidth / Width) * 100 If CLng(Height * nPercent / 100) > MaxHeight Then nPercent = (MaxHeight / Height) * 100 MaxWidth = Width / 100 * nPercent Else MaxHeight = Height / 100 * nPercent End If ' Thumbnail erstellen If GdipGetImageThumbnail(hBitmap, MaxWidth, MaxHeight, hThumb, 0, 0) = 0 Then ' jetzt ein GDI Bitmap vom Vorschaubild erstellen If GdipCreateHBITMAPFromBitmap(hThumb, hDestBitmap, 0) = 0 Then ' jetzt aus dem GDI Bitmap ein StdPicture-Objekt erstellen Set CreateThumbnail = HandleToPicture(hDestBitmap) End If ' Freigeben GdipDisposeImage hThumb End If End If ' Freigeben GdipDisposeImage hBitmap End If ' GDI+ beenden GdiplusShutdown Token End If End Function ' Hilfsfunktion: Erstellt aus einem GDI Bitmap (Handle) ein StdPicture-Objekt Private Function HandleToPicture(ByVal hBmp As Long) As StdPicture Dim IID_IPicture(3) As Long Dim PD As PictDesc Dim NewPic As IPicture IID_IPicture(0) = &H7BF80980 IID_IPicture(1) = &H101ABF32 IID_IPicture(2) = &HAA00BB8B IID_IPicture(3) = &HAB0C3000 With PD .cbSizeofStruct = Len(PD) .hImage = hBmp .picType = vbPicTypeBitmap End With OleCreatePictureIndirect PD, IID_IPicture(0), 1, NewPic ' StdPicture (Bitmap) zurückgeben Set HandleToPicture = NewPic End Function Aufrufbeispiel: Dim sFile As String sFile = "D:\temp\MyPicture.png" Set Image1.Picture = CreateThumbnail(sFile, 128, 128) Dieser Tipp wurde bereits 9.026 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
Neu! sevPopUp 2.0 Dynamische Kontextmenüs! Erstellen Sie mit nur wenigen Zeilen Code Kontextmenüs dynamisch zur Laufzeit. Vordefinierte Styles (XP, Office, OfficeXP, Vista oder Windows 8) erleichtern die Anpassung an die eigenen Anwendung... Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. Access-Tools Vol.1 Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |