Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0663: Grafik mittels GDI+ als JPEG speichern

 von 

Beschreibung 

Dieser Tipp zeigt wie man unter Verwendung von GDI+ Grafiken als JPEG abgespeichert kann. Die Kompressionsrate kann ebenfalls festgelegt werden.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

CLSIDFromString, GdipCreateBitmapFromFile, GdipCreateBitmapFromHBITMAP, GdipCreateHBITMAPFromBitmap, GdipDisposeImage, GdipGetImageEncoders, GdipGetImageEncodersSize, GdipSaveImageToFile, GdiplusShutdown, GdiplusStartup, OleCreatePictureIndirect, lstrcpyW, lstrlenW

Download:

Download des Beispielprojektes [5,5 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 GDIPlusSaveJPG.vbp ----------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (comdlg32.ocx)' wird benötigt.

'--- Anfang Formular "frmGDIPlusSaveJPG" alias frmGDIPlusSaveJPG.frm  ---
' Steuerelement: Horizontale Scrollbar "HScroll1"
' Steuerelement: Schaltfläche "cmdSaveAsJpg"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: Schaltfläche "cmdLoadPicture"
' Steuerelement: Beschriftungsfeld "Label1"

Option Explicit

' ----==== GDIPlus Const ====----
Private Const GdiPlusVersion As Long = 1
Private Const mimeJPG As String = "image/jpeg"
Private Const EncoderParameterValueTypeLong As Long = 4
Private Const EncoderQuality As String = _
    "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

' ----==== Sonstige Types ====----
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

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

' ----==== GDIPlus Types ====----
Private Type GDIPlusStartupInput
    GdiPlusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

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 ImageCodecInfo
    Clsid As GUID
    FormatID As GUID
    CodecNamePtr As Long
    DllNamePtr As Long
    FormatDescriptionPtr As Long
    FilenameExtensionPtr As Long
    MimeTypePtr As Long
    Flags As Long
    Version As Long
    SigCount As Long
    SigSize As Long
    SigPatternPtr As Long
    SigMaskPtr As Long
End Type

' ----==== GDIPlus Enums ====----
Private Enum Status 'GDI+ 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 GdiplusStartup Lib "gdiplus" _
    (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, _
    Optional ByRef lpOutput As Any) As Status

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

Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" _
    (ByVal FileName As Long, ByRef Bitmap As Long) As Status

Private Declare Function GdipSaveImageToFile Lib "gdiplus" _
    (ByVal image As Long, ByVal FileName As Long, _
    ByRef clsidEncoder As GUID, _
    ByRef encoderParams As Any) 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 GdipCreateBitmapFromHBITMAP Lib "gdiplus" _
    (ByVal hbm As Long, ByVal hpal As Long, _
    ByRef Bitmap As Long) As Status

Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" _
    (ByRef numEncoders As Long, ByRef Size As Long) As Status

Private Declare Function GdipGetImageEncoders Lib "gdiplus" _
    (ByVal numEncoders As Long, ByVal Size As Long, _
    ByRef Encoders As Any) As Status

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

' ----==== OLE API Declarations ====----
Private Declare Function CLSIDFromString Lib "ole32" _
    (ByVal str As Long, id As GUID) As Long

Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" _
    (lpPictDesc As PICTDESC, riid As IID, ByVal fOwn As Boolean, _
    lplpvObj As Object)

' ----==== Kernel API Declarations ====----
Private Declare Function lstrlenW Lib "kernel32" _
    (lpString As Any) As Long

Private Declare Function lstrcpyW Lib "kernel32" _
    (lpString1 As Any, lpString2 As Any) As Long

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

'------------------------------------------------------
' 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
    GdipStartupInput.GdiPlusVersion = GdipVersion
    StartUpGDIPlus = GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
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     : 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     : LoadPicturePlus
' Beschreibung : Lädt ein Bilddatei per GDI+
' Übergabewert : Pfad\Dateiname der Bilddatei
' Rückgabewert : StdPicture Objekt
'------------------------------------------------------
Public Function LoadPicturePlus(ByVal FileName As String) As StdPicture
    Dim retStatus As Status
    Dim lBitmap As Long
    Dim hBitmap As Long
    
    ' Öffnet die Bilddatei in lBitmap
    retStatus = Execute(GdipCreateBitmapFromFile(StrPtr(FileName), _
        lBitmap))
    
    If retStatus = OK Then
        
        ' Erzeugen einer GDI Bitmap lBitmap -> hBitmap
        retStatus = Execute(GdipCreateHBITMAPFromBitmap(lBitmap, _
            hBitmap, 0))
        
        If retStatus = OK Then
            ' Erzeugen des StdPicture Objekts von hBitmap
            Set LoadPicturePlus = HandleToPicture(hBitmap, _
                vbPicTypeBitmap)
        End If
        
        ' Lösche lBitmap
        Call Execute(GdipDisposeImage(lBitmap))
        
    End If
End Function

'------------------------------------------------------
' Funktion     : SavePictureAsJPG
' Beschreibung : Speichert ein StdPicture Objekt per GDI+ als JPG
' Übergabewert : Pic = StdPicture Objekt
'                FileName = Pfad\Dateiname.jpg
'                Quality = JPG Kompression
' Rückgabewert : True = speichern erfolgreich
'                False = speichern fehlgeschlagen
'------------------------------------------------------
Private Function SavePictureAsJPG(ByVal Pic As StdPicture, _
    ByVal FileName As String, Optional ByVal Quality As Long = 85) _
    As Boolean
    
    Dim retStatus As Status
    Dim retVal As Boolean
    Dim lBitmap As Long
    
    ' Erzeugt eine GDI+ Bitmap vom StdPicture Handle -> lBitmap
    retStatus = Execute(GdipCreateBitmapFromHBITMAP(Pic.Handle, 0, _
        lBitmap))
    
    If retStatus = OK Then
        
        Dim PicEncoder As GUID
        Dim tParams As EncoderParameters
        
        '// Ermitteln der CLSID vom mimeType Encoder
        retVal = GetEncoderClsid(mimeJPG, PicEncoder)
        If retVal = True Then
            
            If Quality > 100 Then Quality = 100
            If Quality < 0 Then Quality = 0
            
            ' Initialisieren der Encoderparameter
            tParams.Count = 1
            With tParams.Parameter(0) ' Quality
                ' Setzen der Quality GUID
                CLSIDFromString StrPtr(EncoderQuality), .GUID
                .NumberOfValues = 1
                .Type = EncoderParameterValueTypeLong
                .Value = VarPtr(Quality)
            End With
            
            ' Speichert lBitmap als JPG
            retStatus = Execute(GdipSaveImageToFile(lBitmap, _
                StrPtr(FileName), PicEncoder, tParams))
            
            If retStatus = OK Then
                SavePictureAsJPG = True
            Else
                SavePictureAsJPG = False
            End If
        Else
            SavePictureAsJPG = False
            MsgBox "Konnte keinen passenden Encoder ermitteln.", _
            vbOKOnly, "Encoder Error"
        End If
        
        ' Lösche lBitmap
        Call Execute(GdipDisposeImage(lBitmap))
        
    End If
End Function

'------------------------------------------------------
' Funktion     : HandleToPicture
' Beschreibung : Umwandeln einer GDI+ Bitmap Handle in ein StdPicture Objekt
' Übergabewert : hGDIHandle = GDI+ 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     : GetEncoderClsid
' Beschreibung : Ermittelt die Clsid des Encoders
' Übergabewert : mimeType = mimeType des Encoders
'                pClsid = CLSID des Encoders (in/out)
' Rückgabewert : True = Ermitteln erfolgreich
'                False = Ermitteln fehlgeschlagen
'------------------------------------------------------
Private Function GetEncoderClsid(mimeType As String, pClsid As GUID) _
    As Boolean
    
    Dim num As Long
    Dim Size As Long
    Dim pImageCodecInfo() As ImageCodecInfo
    Dim j As Long
    Dim buffer As String
    
    Call GdipGetImageEncodersSize(num, Size)
    If (Size = 0) Then
        GetEncoderClsid = False  '// fehlgeschlagen
        Exit Function
    End If
    
    ReDim pImageCodecInfo(0 To Size \ Len(pImageCodecInfo(0)) - 1)
    Call GdipGetImageEncoders(num, Size, pImageCodecInfo(0))
    
    For j = 0 To num - 1
        buffer = Space$(lstrlenW(ByVal pImageCodecInfo(j).MimeTypePtr))
        
        Call lstrcpyW(ByVal StrPtr(buffer), ByVal _
            pImageCodecInfo(j).MimeTypePtr)
            
        If (StrComp(buffer, mimeType, vbTextCompare) = 0) Then
            pClsid = pImageCodecInfo(j).Clsid
            Erase pImageCodecInfo
            GetEncoderClsid = True  '// erfolgreich
            Exit Function
        End If
    Next j
    
    Erase pImageCodecInfo
    GetEncoderClsid = False  '// fehlgeschlagen
End Function

Private Sub cmdLoadPicture_Click()
    On Error Goto errorhandler
    
    If GdipInitialized = True Then
        
        With CommonDialog1
            .Filter = "Images Files (*.bmp;*.gif;*.jpg;*.png;*.tif)|" & _
                "*.bmp;*.gif;*.jpg;*.png;*.tif"
                
            .CancelError = True
            .ShowOpen
        End With
        
        Picture1.Picture = LoadPicturePlus(CommonDialog1.FileName)
        
        If Not Picture1.Picture Is Nothing Then cmdSaveAsJpg.Enabled = True
    End If
    
    Exit Sub
errorhandler:
End Sub

Private Sub cmdSaveAsJpg_Click()
    On Error Goto errorhandler
    
    If GdipInitialized = True Then
        
        With CommonDialog1
            .Filter = "Images Files (*.jpg)|*.jpg"
            .FileName = "*.jpg"
            .CancelError = True
            .Flags = cdlOFNOverwritePrompt
            .ShowSave
        End With
        
        SavePictureAsJPG Picture1, CommonDialog1.FileName, HScroll1.Value
    End If
    
    Exit Sub
errorhandler:
End Sub

Private Sub Form_Load()
    Dim retStatus As Status
    GdipInitialized = False
    
    retStatus = Execute(StartUpGDIPlus(GdiPlusVersion))
    If retStatus = OK Then
        GdipInitialized = True
    Else
        MsgBox "GDI+ not inizialized.", vbOKOnly, "GDI Error"
    End If
    
    With HScroll1
        .Max = 100
        .Min = 0
        .Value = 85
    End With
    
    cmdSaveAsJpg.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim retStatus As Status

    If GdipInitialized = True Then
        retStatus = Execute(ShutdownGDIPlus)
    End If
End Sub

Private Sub HScroll1_Change()
    Label1.Caption = "JPG Kompression: " & HScroll1.Value
End Sub

Private Sub HScroll1_Scroll()
    HScroll1_Change
End Sub
'--- Ende Formular "frmGDIPlusSaveJPG" alias frmGDIPlusSaveJPG.frm  ---
'----------- Ende Projektdatei GDIPlusSaveJPG.vbp -----------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

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

Kommentar von Frank Schüler am 07.11.2006 um 21:09

Hi Thorsten

Das direkte speichern eines Bildes als JPEG ist mit diesem Tipp möglich. Dazu muss, für diesen Tipp zumindest, das Bild der Webcam in einer PictureBox angezeigt werden (kein Overlay). Für weitere Fragen solltest Du aber besser das VB-Forum nutzen da Dir dort sicher mehr bei Deinem Problem geholfen werden kann.

MFG Frank

Kommentar von Thorsten am 07.11.2006 um 16:29

Ja, der Code den ich habe funktioniert auch soweit, mein Problem liegt zurzeit darin, dass ich die Bilder direkt als jpg speichern muss, und nicht wie z.Z. zuerst als bmp zwischenspeichern und dann wieder löschen. Raubt mir grade den letzten Nerv *g*, aber trotzdem danke ;-)

Kommentar von Frank Schüler am 07.11.2006 um 16:14

Hallo Thorsten

Zur ij11.dll (Intel JPEG) und zum Code von VBAccelerator kann ich Dir keine Auskunft geben. Da musst Du Dich schon an VBAccelerator wenden. Dieser Code hier funktioniert nur mit der gdiplus.dll (GDI+) von Microsoft.

MFG Frank

Kommentar von Thorsten am 07.11.2006 um 15:58

Ich möchte mittels einer Webcam zu erfassende Bilder direkt als jpg speichern, habe mir dazu die ijl11.dll besorgt. Jetzt wollte ich mit dem Code unter dieser URL arbeiten http://www.vbaccelerator.com/home/vb/code/controls/Skins/VB6_NeoCaption_Full_Source_zip_cDIBSection_cls.asp jedoch kommt schon Version 1.0 CLASS der Fehler, expected: end of statement... kann mir jemand helfen? Herzlichen Dank im vorraus

Kommentar von Frank Schüler am 06.11.2006 um 07:02

Hallo Steffi

Eine extreme verfälschung der Farben konnte ich nicht feststellen. Eine leichte Abweichung zur Originalfarbe ist beim GDI+ JPEG-Encoder aber feststellbar. Ändern kannst Du da nicht viel außer der Komprimierungsqualität. Es gibt irgendwo im Internet auch eine Beschreibung mit diversen Einschränkungen zum GDI+ JPEG-Encoder bezüglich der Qualität der erstellten JPEG-Bilder.

MFG Frank

Kommentar von steffi am 18.10.2006 um 13:04

Funktioniert prinzipiell super.
Läuft bei mir unter VBA auf einem Win2003-Server.

Einziges Problem: bei TIFFs werden die Farben teilweise extrem verfälscht!
Z.B. rot wird ziemlich violett - schaut nicht grade toll aus.
(liegt auch wirklich an diesem Code - wenn ich das selbe TIFF mit Photoshop öffne u. als JPG speichere, dann stimmen die Farben schon ungefähr)

Hat jemand eine Idee, was ich ändern könnte, damit die Farben stimmen?

lg Steffi

Kommentar von Andreas Maurer am 05.12.2005 um 23:26

Brilliant!

Kommentar von Paratron am 13.03.2005 um 11:41

Donwload geht niccht!