Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0699: "On-the-fly" das Ergebnis der JPEG-Komprimierung sehen

VB 5/6-Tipp 0699: "On-the-fly" das Ergebnis der JPEG-Komprimierung sehen

 von Frank Schüler

Schwierigkeitsgrad:

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

Download: Download des Beispielprojektes [6,48 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 GDIPlusJPGPreview.vbp  --------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (COMDLG32.OCX)' wird benötigt.

'--- Anfang Formular "frmGDIPlusJPGPreview" alias frmGDIPlusJPGPreview.frm  ---
' Steuerelement: Schaltfläche "cmdLoadPicture"
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: Schaltfläche "cmdSaveAsJPG"
' Steuerelement: Horizontale Scrollbar "hscJpgQuality"
' Steuerelement: Bildfeld-Steuerelement "picPreview"
' Steuerelement: Bildfeld-Steuerelement "picOrg"
' Steuerelement: Beschriftungsfeld "lblJpgFileSize"
' Steuerelement: Beschriftungsfeld "lblJpgQuality"

Option Explicit

' ----==== 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 Const ====----
Private Const CC_STDCALL As Long = 4
Private Const STREAM_SEEK_END As Long = 2
Private Const vtb_Seek As Long = 20

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

Private Type JpgPreviewInfo
    JpgPicture As StdPicture
    JpgFileSize As Double
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 ====----
' GDI+ Status
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 GdipSaveImageToFile Lib "gdiplus" ( _
                         ByVal Image As Long, _
                         ByVal FileName As Long, _
                         ByRef clsidEncoder As GUID, _
                         ByRef encoderParams As Any) As Status
                         
Private Declare Function GdipSaveImageToStream Lib "gdiplus" ( _
                         ByVal Image As Long, _
                         ByVal Stream As IUnknown, _
                         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" ( _
                         ByVal hGlobal As Long, _
                         ByVal fDeleteOnRelease As Long, _
                         ByRef ppstm As Any) As Long
                         
' ----==== OLEOUT32 API Declarationen ====----
Private Declare Sub DispCallFunc Lib "oleaut32" ( _
                    ByVal ppv As IUnknown, _
                    ByVal oVft As Long, _
                    ByVal cc As Long, _
                    ByVal rtTYP As VbVarType, _
                    ByVal paCNT As Long, _
                    ByRef paTypes As Any, _
                    ByRef paValues As Any, _
                    ByRef fuReturn As Variant)
                    
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" ( _
                    ByRef lpPictDesc As PICTDESC, _
                    ByRef riid As GUID, _
                    ByVal fOwn As Boolean, _
                    ByRef lplpvObj As Object)
                    
' ----==== Variablen ====----
Private GdipToken As Long
Private GdipInitialized As Boolean
Private tJpgPreviewInfo As JpgPreviewInfo
Private lValue As Long

' ------------------------------------------------------
' 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 Else:                      s = "Unknown GDI+ Error."
    
    End Select
    
    GdiErrorString = s
    
End Function

' ------------------------------------------------------
' Funktion     : GetStreamSize
' Beschreibung : Größe eines Streams ermitteln
' Übergabewert : Stream = Stream (IUnknown)
' Rückgabewert : Größe des Streams in Bytes
' ------------------------------------------------------
' Originalcode von Udo Schmidt
' udo@activevb.de
' ------------------------------------------------------
Private Function GetStreamSize(ByRef Stream As IUnknown) As Double

    Dim typ(4) As Integer
    Dim off(4) As Long
    Dim var(4) As Variant
    Dim ret As Long
    Dim tgt As Currency
    
    ' Parameter setzen
    typ(0) = vbLong: off(0) = VarPtr(var(0)): var(0) = CLng(0)
    typ(1) = vbLong: off(1) = VarPtr(var(1)): var(1) = CLng(0)
    typ(2) = vbLong: off(2) = VarPtr(var(2)): var(2) = STREAM_SEEK_END
    typ(3) = vbLong: off(3) = VarPtr(var(3)): var(3) = VarPtr(tgt)
    
    ' IStream.Seek
    Call DispCallFunc(Stream, vtb_Seek, CC_STDCALL, vbLong, 4, typ(0), _
        off(0), ret)
        
    If ret Then Debug.Print Err.LastDllError
    
    ' Größe des Streams in Bytes
    GetStreamSize = CDbl(tgt * 10000)
    
End Function

' ------------------------------------------------------
' Funktion     : HandleToPicture
' Beschreibung : Umwandeln eines 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 GUID
    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     : PreviewJpgQuality
' Beschreibung : Vorschau der JPG Kompressionsqualität
'                und ermitteln der zuerwartenden Dateigröße
'                ohne zwischenspeichern auf die Festplatte
' Übergabewert : InPicture = StdPicture Objekt
'                Quality = JPG Kompression
' Rückgabewert : StdPicture Objekt
' ------------------------------------------------------
Private Function PreviewJpgQuality(ByVal InPicture As StdPicture, _
    Optional ByVal Quality As Long = 85) As JpgPreviewInfo
    
    Dim PicStream As IUnknown
    Dim lBitmap As Long
    Dim lNewBitmap As Long
    Dim hNewBitmap As Long
    Dim tGUID As GUID
    Dim tParams As EncoderParameters
    Dim tJpgPreviewInfo As JpgPreviewInfo
    
    If Quality > 100 Then Quality = 100
    If Quality < 0 Then Quality = 0
    
    ' Streamobjekt erstellen
    ' -> PicStream
    If CreateStreamOnHGlobal(0, False, PicStream) = 0 Then
    
        ' Bitmapobjekt vom Handle erstellen
        ' -> lBitmap
        If Execute(GdipCreateBitmapFromHBITMAP(InPicture.Handle, 0, _
            lBitmap)) = OK Then
            
            ' ClsidJpeg zu GUID
            If CLSIDFromString(StrPtr(ClsidJpeg), tGUID) = 0 Then
            
                ' Initialisieren der Encoderparameter
                tParams.Count = 1
                
                With tParams.Parameter(0)
                
                    ' Setzen der Quality GUID
                    CLSIDFromString StrPtr(EncoderQuality), .GUID
                    .NumberOfValues = 1
                    .Type = EncoderParameterValueTypeLong
                    .Value = VarPtr(Quality)
                    
                End With
                
                ' Speichert lBitmap als JPG-Stream
                ' -> PicStream
                If Execute(GdipSaveImageToStream(lBitmap, PicStream, _
                    tGUID, tParams)) = OK Then
                    
                    ' Größe des Streams in Byte ermitteln
                    tJpgPreviewInfo.JpgFileSize = GetStreamSize(PicStream)
                    
                    ' PicStream in ein Bitmapobjekt umwandeln
                    ' -> lNewBitmap
                    If Execute(GdipLoadImageFromStream(PicStream, _
                        lNewBitmap)) = OK Then
                        
                        ' Handle von lNewBitmap ermitteln
                        ' -> hNewBitmap
                        If Execute(GdipCreateHBITMAPFromBitmap( _
                            lNewBitmap, hNewBitmap, 0)) = OK Then
                            
                            ' StdPicture Objekt von
                            ' hNewBitmap erstellen
                            Set tJpgPreviewInfo.JpgPicture = _
                                HandleToPicture(hNewBitmap, _
                                vbPicTypeBitmap)
                                
                        End If
                        
                        ' Lösche lNewBitmap
                        Call Execute(GdipDisposeImage(lNewBitmap))
                        
                    End If
                End If
            End If
            
            ' Lösche lBitmap
            Call Execute(GdipDisposeImage(lBitmap))
            
        End If
        
        ' Lösche Streamobjekt
        Set PicStream = Nothing
        
    End If
    
    ' Parameter zurückgeben
    PreviewJpgQuality = tJpgPreviewInfo
    
End Function

' ------------------------------------------------------
' Funktion     : SaveAsJpg
' Beschreibung : speichert ein StdPicture als JPG Datei
' Übergabewert : InPicture = StdPicture Objekt
'                FileName = Pfad\Dateiname.jpg
'                Quality = JPG Kompression
' Rückgabewert : GDI+ Status
' ------------------------------------------------------
Private Function SaveAsJpg(ByVal InPicture As StdPicture, ByVal FileName _
    As String, Optional ByVal Quality As Long = 85) As Status
    
    Dim lBitmap As Long
    Dim tGUID As GUID
    Dim tParams As EncoderParameters
    
    If Quality > 100 Then Quality = 100
    If Quality < 0 Then Quality = 0
    
    ' Bitmapobjekt vom Handle erstellen
    ' -> lBitmap
    If Execute(GdipCreateBitmapFromHBITMAP(InPicture.Handle, 0, lBitmap)) _
        = OK Then
        
        ' ClsidJpeg zu GUID
        If CLSIDFromString(StrPtr(ClsidJpeg), tGUID) = 0 Then
        
            ' Initialisieren der Encoderparameter
            tParams.Count = 1
            
            With tParams.Parameter(0)
            
                ' Setzen der Quality GUID
                CLSIDFromString StrPtr(EncoderQuality), .GUID
                .NumberOfValues = 1
                .Type = EncoderParameterValueTypeLong
                .Value = VarPtr(Quality)
                
            End With
            
            ' Speichert lBitmap als JPG-Datei
            SaveAsJpg = Execute(GdipSaveImageToFile(lBitmap, StrPtr( _
                FileName), tGUID, tParams))
                
        End If
        
        ' Lösche lBitmap
        Call Execute(GdipDisposeImage(lBitmap))
        
    End If
    
End Function

' ------------------------------------------------------
' Funktion     : ShutdownGDIPlus
' Beschreibung : Beendet die GDI+ Instanz
' Rückgabewert : GDI+ Status
' ------------------------------------------------------
Private Function ShutdownGDIPlus() As Status

    ' Beendet die 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 GdipStartupInput As GDIPlusStartupInput
    Dim GdipStartupOutput As GdiplusStartupOutput
    
    GdipStartupInput.GdiPlusVersion = GdipVersion
    
    StartUpGDIPlus = GdiplusStartup(GdipToken, GdipStartupInput, _
        GdipStartupOutput)
        
End Function

Private Sub cmdLoadPicture_Click()

    ' Fehlerbehandlung
    On Error Goto errorhandler
    
    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
    
        ' Dialogparameter setzen
        With CommonDialog1
        
            .Filter = "Image Files (*.bmp;*.gif;*.jpg)|*.bmp;*.gif;*.jpg"
            .CancelError = True
            .ShowOpen
            
        End With
        
        ' Bild laden
        ' für dieses Beispiel reicht die LoadPicture-Funktion
        picOrg.Picture = LoadPicture(CommonDialog1.FileName)
        
        ' ist ein Bild vorhanden
        If Not picOrg.Picture = Empty Then
        
            ' Button aktivieren
            cmdSaveAsJPG.Enabled = True
            
            ' ScrollBar aktivieren
            hscJpgQuality.Enabled = True
            
            ' Vorschau erzeugen und Größe ermitteln
            Call hscJpgQuality_Change
            
        End If
    End If
    
    Exit Sub
    
errorhandler:

End Sub

Private Sub cmdSaveAsJpg_Click()

    ' Fehlerbehandlung
    On Error Goto errorhandler
    
    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
    
        ' Dialogparameter setzen
        With CommonDialog1
        
            .Filter = "JPG Files (*.jpg)|*.jpg"
            .FileName = "*.jpg"
            .CancelError = True
            .Flags = cdlOFNOverwritePrompt
            .ShowSave
            
        End With
        
        ' StdPicture als JPG Datei speichern
        If SaveAsJpg(picOrg.Picture, CommonDialog1.FileName, lValue) = OK _
            Then
            
            MsgBox "Speichern erfolgreich. Die JPG Datei " & _
                CommonDialog1.FileName & " ist " & CStr( _
                tJpgPreviewInfo.JpgFileSize) & " Bytes groß."
                
        Else
        
            MsgBox "Speichern war nicht erfolgreich."
            
        End If
    End If
    
    Exit Sub
    
errorhandler:

End Sub

Private Sub Form_Load()

    GdipInitialized = False
    
    ' Button deaktivieren
    cmdSaveAsJPG.Enabled = False
    
    ' ScrollBar deaktivieren
    hscJpgQuality.Enabled = False
    
    ' Parameter für die ScrollBar setzen
    With hscJpgQuality
    
        .Max = 100
        .Min = 0
        .Value = 85
        
    End With
    
    ' Parameter für die anderen
    ' Steuerelemente setzen
    lblJpgFileSize.Caption = vbNullString
    lblJpgQuality.Caption = vbNullString
    cmdLoadPicture.Caption = "Load Picture"
    cmdSaveAsJPG.Caption = "Save Picture as JPG"
    
    ' GDI+ initialisieren
    If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
    
        GdipInitialized = True
        
    Else
    
        ' Initialisierung fehlgeschlagen
        MsgBox "GDI+ not inizialized.", vbOKOnly, "GDI Error"
        
    End If
    
End Sub

Private Sub Form_Unload(Cancel As Integer)

    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
    
        ' GDI+ beenden
        Call Execute(ShutdownGDIPlus)
        
    End If
    
End Sub

Private Sub hscJpgQuality_Change()

    Dim dblJpgFileSize As Double
    Dim sJpgFileSize As String
    
    ' zwischenspeichern der Kompressionsrate
    lValue = hscJpgQuality.Value
    
    ' ist GDI+ initialisiert
    If GdipInitialized Then
    
        ' ist ein Bild vorhanden
        If Not picOrg.Picture = Empty Then
        
            ' Vorschau erzeugen und Größe in Byte ermitteln
            tJpgPreviewInfo = PreviewJpgQuality(picOrg.Picture, lValue)
            
            DoEvents
            
            ' Größe in Bytes zwischenspeichern
            dblJpgFileSize = tJpgPreviewInfo.JpgFileSize
            
            ' Vorschaubild anzeigen
            picPreview.Picture = tJpgPreviewInfo.JpgPicture
            
            ' Bytes umrechnen in KB oder MB
            If (dblJpgFileSize / CDbl(1024)) < 1024 Then
            
                sJpgFileSize = Format$(dblJpgFileSize / CDbl(1024), _
                    "#.0") & " KB"
                    
            Else
            
                sJpgFileSize = Format$(dblJpgFileSize / (CDbl(1024) ^ 2), _
                    "#.0") & " MB"
                    
            End If
            
            ' Ausgeben der Kompressionsrate
            lblJpgQuality.Caption = "JPG Quality (Compression): " & CStr( _
                lValue)
                
            ' Ausgeben der Größe
            lblJpgFileSize.Caption = "JPG FileSize: " & sJpgFileSize & _
                " (" & Format$(dblJpgFileSize, "###,###,###,###") & " " & _
                "Bytes)"
                
        End If
    End If
    
End Sub

Private Sub hscJpgQuality_Scroll()

    Call hscJpgQuality_Change
    
End Sub

'--- Ende Formular "frmGDIPlusJPGPreview" alias frmGDIPlusJPGPreview.frm  ---
'--------- Ende Projektdatei GDIPlusJPGPreview.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.