vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Mails senden, abrufen und decodieren - ganz easy ;-)  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: Grafik und Font · Bilder & Icons   |   VB-Versionen: VB609.12.11
Thumbnail (Vorschaubild) mit Hilfe von GDI+ erstellen

Eine Funktion, die unter Einbeziehung der GdiPlus Funktionen aus dem Windows API ein Vorschaubild (Thumbnail) von einer angegebenen Bilddatei erstellt.

Autor:   Dieter OtterBewertung:     [ Jetzt bewerten ]Views:  9.026 
www.tools4vb.deSystem:  WinXP, Win7, Win8, Win10, Win11 Beispielprojekt auf CD 

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

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!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.
 
   

Druckansicht Druckansicht Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
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.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel