Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0696: Bitmap per GDI+ in eine JPEG-komprimierte Zeichenfolge umwandeln

VB 5/6-Tipp 0696: Bitmap per GDI+ in eine JPEG-komprimierte Zeichenfolge umwandeln

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CLSIDFromString, CreateStreamOnHGlobal, GdipCreateBitmapFromHBITMAP, GdipCreateHBITMAPFromBitmap, GdipDisposeImage, GdipLoadImageFromStream, GdipSaveImageToStream, GdiplusShutdown, GdiplusStartup, OleCreatePictureIndirect

Download: Download des Beispielprojektes [46,97 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 GDIPlusPictureToString.vbp ------
' Es muss ein Verweis auf 'IStream Interface TypeLibrary' gesetzt werden.

'--- Anfang Formular "frmPictureToString" alias frmPictureToString.frm  ---
' Steuerelement: Bildfeld-Steuerelement "picNew"
' Steuerelement: Bildfeld-Steuerelement "picOrg"
' Steuerelement: Schaltfläche "cmdTest"

Option Explicit

' Für die Funktion PictureToString wird die IStream.TLB
' von madmax benötigt und ist in diesem Download enthalten.

' Die IStream.TLB kann auch unter folgender Adresse
' herruntergeladen werden.
' http://mitglied.lycos.de/real51/directdl.php?file=IStream.zip

' ----==== GDIPlus Const ====----
Private Const ClsidJPEG As String = _
    "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
    
Private Const EncoderParameterValueTypeLong As Long = 4&

Private Const EncoderQuality As String = _
    "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
    
Private Const GdiPlusVersion As Long = 1&

' ----==== sonstige Types ====----
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

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

Private Type PICTDESC
    cbSizeOfStruct As Long
    picType As Long
    hgdiObj As Long
    hPalOrXYExt As Long
End Type

' ----==== GDIPlus Types ====----
Private Type EncoderParameter
    GUID As GUID
    NumberOfValues As Long
    Type As Long
    Value As Long
End Type

Private Type EncoderParameters
    Count As Long
    Parameter(15) As EncoderParameter
End Type

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

' ----==== GDIPlus Enums ====----
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 Declarationen ====----
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" ( _
                         ByVal hBm As Long, _
                         ByVal hPal 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 GdipLoadImageFromStream Lib "gdiplus" ( _
                         ByVal Stream As IUnknown, _
                         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
                         
Private Declare Function GdipSaveImageToStream Lib "gdiplus" ( _
                         ByVal Image As Long, _
                         ByVal Stream As IStream, _
                         ByRef ClsidEncoder As GUID, _
                         ByRef EncoderParams As Any) As Status
                         
' ----==== OLE32 API Declarationen ====----
Private Declare Function CLSIDFromString Lib "ole32" ( _
                         ByVal Str As Long, _
                         ByRef id As GUID) As Long
                         
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" ( _
                         ByRef hGlobal As Any, _
                         ByVal fDeleteOnRelease As Long, _
                         ByRef ppstm As Any) As Long
                         
' ----==== OLEAUT32 API Declarations ====----
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" ( _
                    ByRef lpPictDesc As PICTDESC, _
                    ByRef riid As IID, _
                    ByVal fOwn As Boolean, _
                    ByRef lplpvObj As Object)
                    
' ----==== Variablen ====----
Private GdipToken As Long
Private GdipInitialized As Boolean
Private strTmp As String

' ------------------------------------------------------
' Funktion     : Execute
' Beschreibung : Gibt im Fehlerfall die entsprechende
'                GDI+ Fehlermeldung aus
' Übergabewert : GDI+ Status
' Rückgabewert : GDI+ Status
' ------------------------------------------------------
Private Function Execute(ByVal eReturn As Status) As Status

    Dim eCurErr As Status
    
    If eReturn = OK Then
    
        eCurErr = OK
        
    Else
    
        eCurErr = eReturn
        
        MsgBox GdiErrorString(eReturn) & " GDI+ Error:" & eReturn, _
            vbOKOnly, "GDI Error"
            
    End If
    
    Execute = eCurErr
    
End Function

' ------------------------------------------------------
' Funktion     : GdiErrorString
' Beschreibung : Umwandlung der GDI+ Statuscodes in Stringcodes
' Übergabewert : GDI+ Status
' Rückgabewert : Fehlercode als String
' ------------------------------------------------------
Private Function GdiErrorString(ByVal eError As Status) As String

    Dim s As String
    
    Select Case eError
    
    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 ProfileNotFound:           s = "Profile Not Found."
    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
'                hpal = Handle auf eine Palette
' 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
    Call OleCreatePictureIndirect(tPictDesc, IID_IPicture, True, oPicture)
    
    ' Rückgabe des Pictureobjekts
    Set HandleToPicture = oPicture
    
End Function

' ------------------------------------------------------
' Funktion     : PictureToString
' Beschreibung : Konvertiert ein StdPicture in einen String der mit der
'                Funktion "StringToPicture" wieder in ein StdPicture
'                konvertiert werden kann.
' Übergabewert : InPicture = StdPicture
'                JpegQuality = JPEG-Kompression/Qualität
' Rückgabewert : StdPicture Objekt
' ------------------------------------------------------
Private Function PictureToString(ByVal InPicture As StdPicture, Optional _
    ByVal JpegQuality As Long = 85) As String
    
    Dim PicStream As IStream
    Dim lBitmap As Long
    Dim tGUID As GUID
    Dim curSize As Currency
    Dim lngSize As Long
    Dim lngBytesRead As Long
    Dim bytBuff() As Byte
    Dim tParams As EncoderParameters
    
    ' Min/Max JPEG-Kompression
    If JpegQuality > 100 Then JpegQuality = 100
    If JpegQuality < 0 Then JpegQuality = 0
    
    ' GDI+ Bitmap vom Handle erstellen
    If Execute(GdipCreateBitmapFromHBITMAP(InPicture.Handle, 0, lBitmap)) _
        = OK Then
        
        ' Stream erstellen
        If CreateStreamOnHGlobal(ByVal 0, False, PicStream) = 0 Then
        
            ' CLSID für JPEG
            If CLSIDFromString(StrPtr(ClsidJPEG), tGUID) = 0 Then
            
                ' JPEG Komprimierungsparameter setzen
                tParams.Count = 1
                
                With tParams.Parameter(0)
                
                    ' Setzen der Quality-GUID
                    CLSIDFromString StrPtr(EncoderQuality), .GUID
                    .NumberOfValues = 1
                    .Type = EncoderParameterValueTypeLong
                    .Value = VarPtr(JpegQuality)
                    
                End With
                
                ' GDI+ Bitmap als JPEG in den Stream speichern
                If Execute(GdipSaveImageToStream(lBitmap, PicStream, _
                    tGUID, tParams)) = OK Then
                    
                    ' Größe des Streams ermitteln
                    If PicStream.Seek(ByVal 0, STREAM_SEEK_END, curSize) _
                        = 0 Then
                        
                        ' Zurück zum Anfang des Streams
                        If PicStream.Seek(ByVal 0, STREAM_SEEK_SET, ByVal _
                            0) = 0 Then
                            
                            lngSize = CLng(curSize * 10000)
                            
                            ' Bytearray dimensionieren
                            ReDim bytBuff(0 To lngSize - 1)
                            
                            ' Daten aus dem Stream in das Bytearray
                            ' kopieren
                            If PicStream.Read(bytBuff(0), lngSize, _
                                lngBytesRead) = 0 Then
                                
                                ' Bytearray in einen String konverieren
                                PictureToString = bytBuff()
                                
                            End If
                            
                        End If
                        
                    End If
                    
                End If
                
            End If
            
            ' Stream löschen
            Set PicStream = Nothing
            
        End If
        
        ' GDI+ Bitmap löschen
        Call Execute(GdipDisposeImage(lBitmap))
        
    End If
    
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 GdipStartupInput As GDIPlusStartupInput
    Dim GdipStartupOutput As GdiplusStartupOutput
    
    GdipStartupInput.GdiPlusVersion = GdipVersion
    
    StartUpGDIPlus = GdiplusStartup(GdipToken, GdipStartupInput, _
        GdipStartupOutput)
        
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     : StringToPicture
' Beschreibung : Konvertiert einen String, der zuvor über die Funktion
'                "PictureToString" erstellt wurde, wieder in
'                ein StdPicture Objekt
' Übergabewert : strPicture = String
' Rückgabewert : StdPicture Objekt
' ------------------------------------------------------
Private Function StringToPicture(ByVal strPicture As String) As StdPicture

    Dim PicStream As IUnknown
    Dim lBitmap As Long
    Dim hBitmap As Long
    Dim bytBuff() As Byte
    
    ' String in ein Bytearray konvertieren
    bytBuff() = strPicture
    
    ' Stream vom Bytearray erstellen
    If CreateStreamOnHGlobal(bytBuff(0), False, PicStream) = 0 Then
    
        ' GDI+ Bitmap aus dem Stream erstellen
        If Execute(GdipLoadImageFromStream(PicStream, lBitmap)) = OK Then
        
            ' Handle der GDI+ Bitmap ermitteln
            If Execute(GdipCreateHBITMAPFromBitmap(lBitmap, hBitmap, 0)) _
                = OK Then
                
                ' Handle zu einem StdPicture konvertieren
                Set StringToPicture = HandleToPicture(hBitmap, _
                    vbPicTypeBitmap)
                    
            End If
            
            ' GDI+ Bitmap löschen
            Call Execute(GdipDisposeImage(lBitmap))
            
        End If
        
        ' Stream löschen
        Set PicStream = Nothing
        
    End If
    
End Function

Private Sub cmdTest_Click()

    ' ist GDI+ gestartet
    If GdipInitialized Then
    
        ' StdPicture zu einem String konvertieren
        strTmp = PictureToString(picOrg.Picture, 85)
        
        ' String zu einem StdPicture konvertieren
        picNew.Picture = StringToPicture(strTmp)
        
    End If
    
End Sub

Private Sub Form_Load()

    GdipInitialized = False
    
    ' GDI+ starten
    If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
    
        GdipInitialized = True
        
    Else
    
        MsgBox "GDI+ not inizialized.", vbOKOnly, "GDI Error"
        
    End If
    
End Sub

Private Sub Form_Unload(Cancel As Integer)

    If GdipInitialized = True Then
    
        ' GDI+ beenden
        Call Execute(ShutdownGDIPlus)
        
    End If
    
End Sub
'--- Ende Formular "frmPictureToString" alias frmPictureToString.frm  ---
'------- Ende Projektdatei GDIPlusPictureToString.vbp -------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 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.