Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0666: EXIF-Vorschaubild aus JPEG-Datei anzeigen

VB 5/6-Tipp 0666: EXIF-Vorschaubild aus JPEG-Datei anzeigen

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: RtlMoveMemory (CopyMemory), CreateStreamOnHGlobal, GdipCreateBitmapFromFile, GdipCreateHBITMAPFromBitmap, GdipDisposeImage, GdipGetPropertyCount, GdipGetPropertyIdList, GdipGetPropertyItem, GdipGetPropertyItemSize, GdipLoadImageFromStream, GdiplusShutdown, GdiplusStartup, OleCreatePictureIndirect

Download: Download des Beispielprojektes [33,34 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------- Anfang Projektdatei GDIPlusExifThumbnail.vbp -------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (comdlg32.ocx)' wird benötigt.

'--- Anfang Formular "frmGDIPlusExifThumbnail" alias frmGDIPlusExifThumbnail.frm  ---
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: Schaltfläche "cmdLoadPicture"
' Steuerelement: Bildfeld-Steuerelement "picExifThumbnail"
' Steuerelement: Bildfeld-Steuerelement "picJpgPicture"


' *********************************************************
' *  basiert auf den .NET 1.0 Code von Kourosh Derakshan  *
' *  http://vbforums.com/showthread.php?t=342386          *
' *  http://vbforums.com/showthread.php?t=342390          *
' *********************************************************

Option Explicit

' ----==== GDI+ Konstanten ====----
Private Const GdiPlusVersion As Long = 1

' ----==== sonstige Konstanten ====----
' EXIF-Tag: ThumbnailData
Private Const ThumbnailData As Long = &H501B&

' ----==== GDI+ Typen ====----
Private Type GDIPlusStartupInput
    GdiPlusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Private Type GdiplusStartupOutput
    NotificationHook As Long
    NotificationUnhook As Long
End Type

Private Type PropertyItem
    id As Long
    length As Long
    Type As Integer
    Value As Long
End Type

' ----==== Sonstige Typen ====----
Private Type PICTDESC
    cbSizeOfStruct As Long
    picType As Long
    hgdiObj As Long
    hPalOrXYExt As Long
End Type

Private Type IID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7)  As Byte
End Type

' ----==== GDI+ Enums ====----
' GDI+ Status Konstanten
Private Enum Status
    OK = 0
    GenericError = 1
    InvalidParameter = 2
    OutOfMemory = 3
    ObjectBusy = 4
    InsufficientBuffer = 5
    NotImplemented = 6
    Win32Error = 7
    WrongState = 8
    Aborted = 9
    FileNotFound = 10
    ValueOverflow = 11
    AccessDenied = 12
    UnknownImageFormat = 13
    FontFamilyNotFound = 14
    FontStyleNotFound = 15
    NotTrueTypeFont = 16
    UnsupportedGdiplusVersion = 17
    GdiplusNotInitialized = 18
    PropertyNotFound = 19
    PropertyNotSupported = 20
    ProfileNotFound = 21
End Enum

' ----==== GDI+ API-Deklarationen ====----
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" _
    (ByVal FileName As Long, ByRef bitmap As Long) As Status

Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" _
    (ByVal bitmap As Long, ByRef hbmReturn As Long, _
    ByVal Background As Long) As Status

Private Declare Function GdipDisposeImage Lib "gdiplus" _
    (ByVal Image As Long) As Status

Private Declare Function GdipGetPropertyCount Lib "gdiplus" _
    (ByVal Image As Long, ByRef numOfProperty As Long) As Status

Private Declare Function GdipGetPropertyIdList Lib "gdiplus" _
    (ByVal Image As Long, ByVal numOfProperty As Long, _
    ByRef list As Long) As Status

Private Declare Function GdipGetPropertyItem Lib "gdiplus" _
    (ByVal Image As Long, ByVal propId As Long, _
    ByVal propSize As Long, ByRef buffer As Any) As Status

Private Declare Function GdipGetPropertyItemSize Lib "gdiplus" _
    (ByVal Image As Long, ByVal propId As Long, _
    ByRef Size As Long) As Status

Private Declare Function GdipLoadImageFromStream Lib "gdiplus" _
    (ByVal Stream As Any, ByRef Image As Long) As Status

Private Declare Function GdiplusShutdown Lib "gdiplus" _
    (ByVal token As Long) As Status

Private Declare Function GdiplusStartup Lib "gdiplus" _
    (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, _
    ByRef lpOutput As GdiplusStartupOutput) As Status

' ----==== OLE32 API-Deklarationen ====----
Private Declare Sub CreateStreamOnHGlobal Lib "ole32.dll" _
    (ByRef hGlobal As Any, ByVal fDeleteOnRelease As Long, _
    ByRef ppstm As Any)

' ----==== OLEAUT32 API-Deklarationen ====----
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" _
    (lpPictDesc As PICTDESC, riid As IID, ByVal fOwn As Boolean, _
    lplpvObj As Object)

' ----==== Kernel API-Deklarationen ====----
Private Declare Sub CopyMemory Lib "kernel32" Alias _
    "RtlMoveMemory" (pDst As Any, pSrc As Any, _
    ByVal ByteLen As Long)

' ----==== Variablen ====----
Private GdipToken As Long

'------------------------------------------------------
' Funktion     : CheckExifAndThumbnail
' Beschreibung : Überprüft, ob EXIF-Daten und ein
'                EXIF-Thumbnail vorhanden sind
' Übergabewert : lInBitmap = GDI+ Bitmapobjekt
' Rückgabewert : True = EXIF-Daten und
'                       EXIF-Thumbnail sind vorhanden
'                False = EXIF-Daten und/oder
'                        EXIF-Thumbnail sind nicht vorhanden
'------------------------------------------------------
Private Function CheckExifAndThumbnail( _
    ByVal lInBitmap As Long) As Boolean
    
    Dim lPropCount As Long
    Dim lPropItem As Long
    Dim lPropList() As Long
    Dim bRet As Boolean
    
    bRet = False
    
    ' Anzahl der EXIF-Metatags ermitteln
    If Execute(GdipGetPropertyCount(lInBitmap, _
    lPropCount)) = OK Then
        
        ' sind EXIF-Metatags vorhanden
        If (lPropCount > 0) Then
            
            ' Array zur Aufnahme der
            ' EXIF-Metatags dimensionieren
            ReDim lPropList(0 To lPropCount - 1)
            
            ' Liste der EXIF-Metatags auslesen -> lPropList()
            If Execute(GdipGetPropertyIdList(lInBitmap, _
            lPropCount, ByVal VarPtr(lPropList(0)))) = OK Then
                
                ' Liste der EXIF-Metatags durchlaufen
                For lPropItem = 0 To lPropCount - 1
                    
                    ' ist in der Liste der EXIF-Metatag
                    ' "ThumbnailData" vorhanden
                    If lPropList(lPropItem) = ThumbnailData Then
                        
                        ' wenn ja, dann Rückgabewert setzen und
                        ' Schleife verlassen
                        bRet = True
                        Exit For
                    End If
                    
                Next lPropItem
                
            End If
        End If
    End If
    
    ' Rückgabewert ausgeben
    CheckExifAndThumbnail = bRet
End Function

'------------------------------------------------------
' Funktion     : Execute
' Beschreibung : Gibt im Fehlerfall die entsprechende
'                GDI+ Fehlermeldung aus
' Übergabewert : GDI+ Status
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function Execute(ByVal lReturn As Status) As Status
    Dim lCurErr As Status
    If lReturn = Status.OK Then
        lCurErr = Status.OK
    Else
        lCurErr = lReturn
        MsgBox GdiErrorString(lReturn) & " GDI+ Error:" _
        & lReturn, vbOKOnly, "GDI Error"
    End If
    Execute = lCurErr
End Function

'------------------------------------------------------
' Funktion     : GdiErrorString
' Beschreibung : Umwandlung der GDI+ Statuscodes
'                in Stringcodes
' Übergabewert : GDI+ Status
' Rückgabewert : Fehlercode als String
'------------------------------------------------------
Private Function GdiErrorString(ByVal lError As Status) As String
    Dim s As String
    
    Select Case lError
    Case GenericError:              s = "Generic Error."
    Case InvalidParameter:          s = "Invalid Parameter."
    Case OutOfMemory:               s = "Out Of Memory."
    Case ObjectBusy:                s = "Object Busy."
    Case InsufficientBuffer:        s = "Insufficient Buffer."
    Case NotImplemented:            s = "Not Implemented."
    Case Win32Error:                s = "Win32 Error."
    Case WrongState:                s = "Wrong State."
    Case Aborted:                   s = "Aborted."
    Case FileNotFound:              s = "File Not Found."
    Case ValueOverflow:             s = "Value Overflow."
    Case AccessDenied:              s = "Access Denied."
    Case UnknownImageFormat:        s = "Unknown Image Format."
    Case FontFamilyNotFound:        s = "FontFamily Not Found."
    Case FontStyleNotFound:         s = "FontStyle Not Found."
    Case NotTrueTypeFont:           s = "Not TrueType Font."
    Case UnsupportedGdiplusVersion: s = "Unsupported Gdiplus Version."
    Case GdiplusNotInitialized:     s = "Gdiplus Not Initialized."
    Case PropertyNotFound:          s = "Property Not Found."
    Case PropertyNotSupported:      s = "Property Not Supported."
    Case Else:                      s = "Unknown GDI+ Error."
    End Select
    
    GdiErrorString = s
End Function

'------------------------------------------------------
' Funktion     : HandleToPicture
' Beschreibung : Umwandeln einer Bitmap Handle in
'                ein StdPicture Objekt
' Übergabewert : hGDIHandle = Bitmap Handle
'                ObjectType = Bitmaptyp
' Rückgabewert : StdPicture Objekt
'------------------------------------------------------
Private Function HandleToPicture( _
    ByVal hGDIHandle As Long, _
    ByVal ObjectType As PictureTypeConstants, _
    Optional ByVal hpal As Long = 0) As StdPicture
    
    Dim tPictDesc As PICTDESC
    Dim IID_IPicture As IID
    Dim oPicture As IPicture
    
    ' Initialisiert die PICTDESC Structur
    With tPictDesc
        .cbSizeOfStruct = Len(tPictDesc)
        .picType = ObjectType
        .hgdiObj = hGDIHandle
        .hPalOrXYExt = hpal
    End With
    
    ' Initialisiert das IPicture Interface ID
    With IID_IPicture
        .Data1 = &H7BF80981
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(3) = &HAA
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    
    ' Erzeugen des Objekts
    OleCreatePictureIndirect tPictDesc, _
    IID_IPicture, True, oPicture
    
    ' Rückgabe des Pictureobjekts
    Set HandleToPicture = oPicture
    
End Function

'------------------------------------------------------
' Funktion     : ShowExifThumbnail
' Beschreibung : EXIF-Vorschaubild aus
'                GDI+ Bitmapobjekt auslesen
' Übergabewert : lInBitmap = GDI+ Bitmapobjekt
' Rückgabewert : StdPicture Objekt
'------------------------------------------------------
Private Function ShowExifThumbnail( _
    ByVal lInBitmap As Long) As StdPicture
    
    Dim Stream As IUnknown
    Dim lExifThumb As Long
    Dim lPropSize As Long
    Dim bBuffer() As Byte
    Dim bImageBuffer() As Byte
    Dim tPropertyItem As PropertyItem
    
    ' Größe der Propertydaten ermitteln
    If Execute(GdipGetPropertyItemSize(lInBitmap, _
    ThumbnailData, lPropSize)) = OK Then
        
        ' sind Daten vorhanden
        If lPropSize > 0 Then
            
            ' Buffer zur Aufnahme der
            ' Propertydaten dimensionieren
            ReDim bBuffer(lPropSize - 1)
            
            ' Propertydaten auslesen
            If Execute(GdipGetPropertyItem(lInBitmap, _
            ThumbnailData, lPropSize, bBuffer(0))) = OK Then
                
                ' PropertyItem-Struktur aus dem
                ' Propertydaten-Buffer kopieren
                Call CopyMemory(tPropertyItem, bBuffer(0), _
                LenB(tPropertyItem))
                
                ' sind Daten vorhanden
                If tPropertyItem.length > 0 Then
                    
                    ' Buffer zur Aufnahme der
                    ' Imagedaten dimensionieren
                    ReDim bImageBuffer(tPropertyItem.length - 1)
                    
                    ' Imagedaten aus dem
                    ' Propertydaten-Buffer kopieren
                    Call CopyMemory(bImageBuffer(0), _
                    bBuffer(LenB(tPropertyItem)), _
                    tPropertyItem.length)
                    
                    ' Stream vom Imagedaten-Buffer erzeugen
                    Call CreateStreamOnHGlobal(bImageBuffer(0), _
                    False, Stream)
                    
                    ' ist ein Stream vorhanden
                    If Not (Stream Is Nothing) Then
                        
                        ' GDI+ Bitmapobjekt vom Stream
                        ' erstellen -> lExifThumb
                        If Execute(GdipLoadImageFromStream( _
                        Stream, lExifThumb)) = OK Then
                            
                            ' StdPicture Objekt erstellen
                            Set ShowExifThumbnail = _
                            ShowPicture(lExifThumb)
                            
                            ' Bitmapobjekt lExifThumb löschen
                            Call Execute(GdipDisposeImage(lExifThumb))
                        End If
                    End If
                End If
            End If
        End If
    End If
End Function

'------------------------------------------------------
' Funktion     : ShowPicture
' Beschreibung : Umwandeln eines GDI+ Bitmapobjektes
'                in ein StdPicture Objekt
' Übergabewert : lInBitmap = GDI+ Bitmapobjekt
' Rückgabewert : StdPicture Objekt
'------------------------------------------------------
Private Function ShowPicture(ByVal lInBitmap As Long) As StdPicture
    
    Dim hBitmap As Long
    
    ' Handle des Bitmapobjektes ermitteln
    If Execute(GdipCreateHBITMAPFromBitmap( _
    lInBitmap, hBitmap, 0)) = OK Then
        
        ' StdPicture Objekt erstellen
        Set ShowPicture = _
        HandleToPicture(hBitmap, vbPicTypeBitmap)
        
    End If
End Function

'------------------------------------------------------
' Funktion     : ShutDownGDIPlus
' Beschreibung : Beendet die GDI+ Instanz
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function ShutDownGDIPlus() As Status
    ' Beendet GDI+ Instanz
    ShutDownGDIPlus = GdiplusShutdown(GdipToken)
End Function

'------------------------------------------------------
' Funktion     : StartUpGDIPlus
' Beschreibung : Initialisiert GDI+ Instanz
' Übergabewert : GDI+ Version
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function StartUpGDIPlus(ByVal GdipVersion As Long) As Status
    ' Initialisieren der GDI+ Instanz
    Dim tGdipStartupInput As GDIPlusStartupInput
    Dim tGdipStartupOutput As GdiplusStartupOutput
    
    tGdipStartupInput.GdiPlusVersion = GdipVersion
    StartUpGDIPlus = GdiplusStartup(GdipToken, _
    tGdipStartupInput, tGdipStartupOutput)
End Function

Private Sub cmdLoadPicture_Click()
    
    ' Fehlerbehandlung
    On Error Goto errorhandler
    
    Dim lBitmap As Long
    
    ' Parameter für den Dialog setzen
    With CommonDialog1
        .Filter = "JPG Files (*.JPG;*.JPEG;*.JPE;*.JFIF" _
        & "|*.JPG;*.JPEG;*.JPE;*.JFIF"
        .CancelError = True
        .ShowOpen
    End With
    
    ' GDI+ initialisieren
    If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
        
        ' GDI+ Bitmapobjekt von Datei
        ' erstellen -> lBitmap
        If Execute(GdipCreateBitmapFromFile( _
        StrPtr(CommonDialog1.FileName), lBitmap)) = OK Then
            
            ' normales Bild anzeigen
            picJpgPicture.Picture = ShowPicture(lBitmap)
            
            ' sind EXIF-Daten und ein
            ' EXIF-Vorschaubild vorhanden
            If CheckExifAndThumbnail(lBitmap) = True Then
                
                ' EXIF-Vorschaubild anzeigen
                picExifThumbnail.Picture = _
                ShowExifThumbnail(lBitmap)
            Else
                
                ' EXIF-Vorschaubild löschen
                Set picExifThumbnail.Picture = Nothing
            End If
            
            ' GDI+ Bitmapobjekt lBitmap löschen
            Call Execute(GdipDisposeImage(lBitmap))
        End If
        
        ' GDI+ beenden
        Call Execute(ShutDownGDIPlus)
    End If
    Exit Sub
    
errorhandler:
End Sub
'--- Ende Formular "frmGDIPlusExifThumbnail" alias frmGDIPlusExifThumbnail.frm  ---
'-------- Ende Projektdatei GDIPlusExifThumbnail.vbp --------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 4 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.