Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0679: Gammawert eines Bildes mit GDI+ verändern

VB 5/6-Tipp 0679: Gammawert eines Bildes mit GDI+ verändern

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GdipCreateBitmapFromFile, GdipCreateBitmapFromGraphics, GdipCreateBitmapFromHBITMAP, GdipCreateFromHDC, GdipCreateHBITMAPFromBitmap, GdipCreateImageAttributes, GdipDeleteGraphics, GdipDisposeImage, GdipDisposeImageAttributes, GdipDrawImageRect, GdipDrawImageRectRect, GdipGetImageDimension, GdipGetImageGraphicsContext, GdipSetImageAttributesGamma, GdiplusShutdown, GdiplusStartup, OleCreatePictureIndirect

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

'--- Anfang Formular "frmGDIPlusGamma" alias frmGDIPlusGamma.frm  ---
' Steuerelement: Horizontale Scrollbar "hscGamma"
' Steuerelement: Bildfeld-Steuerelement "picGamma"
' Steuerelement: Bildfeld-Steuerelement "picOrg"
' Steuerelement: Schaltfläche "cmdLoadPicture"
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"

Option Explicit

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

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

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

' ----==== GDI+ Enumerationen ====----
Private Enum ColorAdjustType
    ColorAdjustTypeDefault = 0
    ColorAdjustTypeBitmap = 1
    ColorAdjustTypeBrush = 2
    ColorAdjustTypePen = 3
    ColorAdjustTypeText = 4
    ColorAdjustTypeCount = 5
    ColorAdjustTypeAny = 6
End Enum

' 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

Private Enum Unit
    UnitWorld = 0
    UnitDisplay = 1
    UnitPixel = 2
    UnitPoint = 3
    UnitInch = 4
    UnitDocument = 5
    UnitMillimeter = 6
End Enum

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

Private Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" _
    (ByVal Width As Long, ByVal Height As Long, _
    ByVal target As Long, ByRef Bitmap 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 GdipCreateFromHDC Lib "gdiplus" _
    (ByVal hdc As Long, ByRef graphics 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 GdipCreateImageAttributes Lib "gdiplus" _
    (ByRef imageattr As Long) As Status

Private Declare Function GdipDeleteGraphics Lib "gdiplus" _
    (ByVal graphics As Long) As Status

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

Private Declare Function GdipDisposeImageAttributes Lib "gdiplus" _
    (ByVal imageattr As Long) As Status

Private Declare Function GdipDrawImageRect Lib "gdiplus" _
    (ByVal graphics As Long, ByVal image As Long, _
    ByVal X As Single, ByVal Y As Single, ByVal Width As Single, _
    ByVal Height As Single) As Status

Private Declare Function GdipDrawImageRectRect Lib "gdiplus" _
    (ByVal graphics As Long, ByVal image As Long, _
    ByVal dstx As Single, ByVal dsty As Single, _
    ByVal dstwidth As Single, ByVal dstheight As Single, _
    ByVal srcx As Single, ByVal srcy As Single, _
    ByVal srcwidth As Single, ByVal srcheight As Single, _
    ByVal srcUnit As Unit, _
    Optional ByVal imageAttributes As Long = 0, _
    Optional ByVal callback As Long = 0, _
    Optional ByVal callbackData As Long = 0) As Status

Private Declare Function GdipGetImageDimension Lib "gdiplus" _
    (ByVal image As Long, ByRef Width As Single, _
    ByRef Height As Single) As Status

Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" _
    (ByVal image As Long, ByRef graphics 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 GdipSetImageAttributesGamma Lib "gdiplus" _
    (ByVal imageattr As Long, _
    ByVal ColorAdjust As ColorAdjustType, _
    ByVal enableFlag As Boolean, ByVal gamma As Single) As Status

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

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

'------------------------------------------------------
' Funktion     : DrawImageGammaFromImage
' Beschreibung : Bild mit Gammakorrektur erstellen
' Übergabewert : oPic = StdPicture Objekt
'                lDrawHdc = HDC in dem gezeichnet werden soll
'                sGamma = Gammawert
'------------------------------------------------------
Private Sub DrawImageGammaFromImage(ByVal oPic As StdPicture, _
    ByVal lDrawHdc As Long, Optional ByVal sGamma As Single = 1)
    
    Dim lImgAttr As Long
    Dim lBitmap As Long
    Dim lBitmap2 As Long
    Dim lGraphics As Long
    Dim lGraphics2 As Long
    Dim sImageWidth As Single
    Dim sImageHeight As Single
    
    ' nur positive Werte
    sGamma = Abs(sGamma)
    
    ' Gammawert darf nicht = 0 sein
    If sGamma = 0 Then sGamma = sGamma + 1E-45
    
    ' Graphicsobjekts vom Hdc erstellen
    ' lDrawhdc -> lGraphics
    If Execute(GdipCreateFromHDC(lDrawHdc, _
    lGraphics)) = OK Then
        
        ' Bitmapobjekte vom StdPicture Handle erstellen
        ' oPic.Handle -> lBitmap
        If Execute(GdipCreateBitmapFromHBITMAP(oPic.Handle, _
        0, lBitmap)) = OK Then
            
            ' Dimensionen des Bitmapobjektes ermitteln
            Call Execute(GdipGetImageDimension(lBitmap, _
            sImageWidth, sImageHeight))
            
            ' Erzeugen eines ImageAttributeobjekts
            If Execute(GdipCreateImageAttributes( _
            lImgAttr)) = OK Then
                
                ' GammaAttribute für das
                ' ImageAttributeobjekt setzen
                If Execute(GdipSetImageAttributesGamma(lImgAttr, _
                ColorAdjustTypeDefault, True, sGamma)) = OK Then
                    
                    ' neues Graphicsobjekt vom
                    ' Bitmapobjekt erstellen
                    ' lBitmap -> lGraphics2
                    If Execute(GdipGetImageGraphicsContext( _
                    lBitmap, lGraphics2)) = OK Then
                        
                        ' neues Bitmapobjekt vom neuen
                        ' Graphicsobjekt erstellen
                        ' lGraphics2 -> lBitmap2
                        If Execute(GdipCreateBitmapFromGraphics( _
                        sImageWidth, sImageHeight, _
                        lGraphics2, lBitmap2)) = OK Then
                            
                            ' lGraphics2 löschen
                            Call Execute(GdipDeleteGraphics( _
                            lGraphics2))
                            
                            ' neues Graphicsobjekt vom
                            ' Bitmapobjekt erstellen
                            ' lBitmap2 -> lGraphics2
                            If Execute(GdipGetImageGraphicsContext( _
                            lBitmap2, lGraphics2)) = OK Then
                                
                                ' Zeichnet lBitmap in das
                                ' Graphicsobjekt lGraphics2 mit
                                ' entsprechenden ImageAttributen
                                Call Execute(GdipDrawImageRectRect( _
                                lGraphics2, lBitmap, _
                                0, 0, sImageWidth, sImageHeight, _
                                0, 0, sImageWidth, sImageHeight, _
                                UnitPixel, lImgAttr))
                                
                                ' lGraphics2 löschen
                                Call Execute(GdipDeleteGraphics( _
                                lGraphics2))
                                
                                ' lBitmap löschen
                                Call Execute(GdipDisposeImage( _
                                lBitmap))
                                
                                ' Zeichnet lBitmap2 in das
                                ' Graphicsobjekt lGraphics mit
                                Call Execute(GdipDrawImageRect( _
                                lGraphics, lBitmap2, 0, 0, _
                                sImageWidth, sImageHeight))
                                
                                ' lBitmap2 löschen
                                Call Execute(GdipDisposeImage( _
                                lBitmap2))
                            End If
                        End If
                    End If
                End If
                
                ' lImgAttr löschen
                Call Execute(GdipDisposeImageAttributes(lImgAttr))
            End If
        End If
        
        ' lGraphics löschen
        Call Execute(GdipDeleteGraphics(lGraphics))
    End If
End Sub

'------------------------------------------------------
' 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 = OK Then
        lCurErr = 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 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 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     : LoadPicturePlus
' Beschreibung : Lädt ein Bilddatei per GDI+ vom Datenträger
' Übergabewert : sFileName = Pfad\Dateiname der Bilddatei
' Rückgabewert : StdPicture Objekt
'------------------------------------------------------
Public Function LoadPicturePlus( _
    ByVal sFileName As String) As StdPicture
    
    Dim lBitmap As Long
    Dim hBitmap As Long
    
    ' Laden der Bilddatei -> lBitmap
    If Execute(GdipCreateBitmapFromFile(StrPtr(sFileName), _
    lBitmap)) = OK Then
        
        ' Handle von lBitmap ermitten -> hBitmap
        If Execute(GdipCreateHBITMAPFromBitmap(lBitmap, _
        hBitmap, 0)) = 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     : 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 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 = "Images Files (*.bmp;*.gif;*.jpg;*.png;" & _
            "*.tif)|*.bmp;*.gif;*.jpg;*.png;*.tif"
            .CancelError = True
            .ShowOpen
        End With
        
        'Lädt die Datei in die PictureBox
        picOrg.Picture = LoadPicturePlus(CommonDialog1.FileName)
        
        'ist ein Bild vorhanden
        If Not picOrg.Picture = Empty Then
            
            ' Scrollbar aktivieren
            hscGamma.Enabled = True
            
            ' Bild mit Gammakorrektur erstellen
            Call HScgamma_Scroll
        End If
    End If
    
    Exit Sub
errorhandler:
End Sub

Private Sub Form_Load()
    
    GdipInitialized = False
    
    ' Form Parameter setzen
    With Me
        .ScaleMode = vbTwips
        .Height = 4300
        .Width = 6300
        .Caption = "Gammawert = 1,000"
    End With
    
    ' Button Parameter setzen
    With cmdLoadPicture
        .Move 60, 60, 1700, 375
        .Caption = "Load Picture"
    End With
    
    ' picOrg positionieren
    picOrg.Move 60, 60 + cmdLoadPicture.Top _
    + cmdLoadPicture.Height, 3000, 3000
    
    ' picGamma positionieren und Parameter setzen
    With picGamma
        .Move 60 + picOrg.Left + picOrg.Width, _
        picOrg.Top, 3000, 3000
        .AutoRedraw = True
    End With
    
    ' hscGamma positionieren und Parameter setzen
    With hscGamma
        .Move 60, 60 + picOrg.Top + picOrg.Height, _
        picGamma.Left + picGamma.Width - 60, 315
        .Enabled = False
        .Max = 10000
        .Min = 1
        .Value = 1000
    End With
    
    ' GDI+ initialisieren
    If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
        GdipInitialized = True
    Else
        ' Initialisirung 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 HScgamma_Change()
    HScgamma_Scroll
End Sub

Private Sub HScgamma_Scroll()
    
    Dim sGammaVal As Single
    
    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
        
        ' ist ScrollBar aktiv
        If hscGamma.Enabled = True Then
            
            sGammaVal = CSng(hscGamma.Value / 1000)
            
            Me.Caption = "Gammawert = " _
            & Format$(sGammaVal, "0.000")
            
            picGamma.Cls
            
            ' Bild mit Gammakorrektur erstellen
            ' !!! Gammawert darf nicht = 0 sein !!!
            Call DrawImageGammaFromImage(picOrg.Picture, _
            picGamma.hdc, sGammaVal)
            
            picGamma.Refresh
        End If
    End If
End Sub
'--- Ende Formular "frmGDIPlusGamma" alias frmGDIPlusGamma.frm  ---
'------------ Ende Projektdatei GDIPlusGamma.vbp ------------