Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0791: Farbmanipulation per ColorAdjustment

VB 5/6-Tipp 0791: Farbmanipulation per ColorAdjustment

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CreateCompatibleBitmap, CreateCompatibleDC, DeleteDC, GetColorAdjustment, GetDC, GetObjectA (GetObject), GetStretchBltMode, OleCreatePictureIndirect, ReleaseDC, SelectObject, SetColorAdjustment, SetStretchBltMode, StretchBlt

Download: Download des Beispielprojektes [47 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 Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Rahmensteuerelement "Frame1" (Index von 0 bis 1)
' Steuerelement: Listen-Steuerelement "lbIllum" auf Frame1
' Steuerelement: Kontrollkästchen-Steuerelement "ckFlags" (Index von 0 bis 1) auf Frame1
' Steuerelement: Horizontale Scrollbar "scrColor" (Index von 0 bis 8)
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Beschriftungsfeld "lblInf" (Index von 0 bis 8)
' Steuerelement: Beschriftungsfeld "lblVal" (Index von 0 bis 8)
Option Explicit

Private isLoad As Boolean

Private Sub Form_Load()

    Dim lngIndex As Long
    
    ' Flag wenn die Form geladen wird
    isLoad = True
    
    ' Werte für die ScrollBars setzen
    For lngIndex = 0 To scrColor.Count - 1
    
        Select Case lngIndex
        
        Case 0, 1, 2
        
            With scrColor(lngIndex)
                .Max = 32500
                .Min = 1250
                .Value = 5000
            End With
            
        Case 3
        
            With scrColor(3)
                .Max = 4000
                .Min = 0
                .Value = 0
            End With
            
        Case 4
        
            With scrColor(4)
                .Max = 10000
                .Min = 6000
                .Value = 10000
            End With
            
        Case 5, 6, 7, 8
        
            With scrColor(lngIndex)
                .Max = 100
                .Min = -100
                .Value = 0
            End With
            
        End Select
        
    Next lngIndex
    
    ' ListBox mit Daten füllen
    lbIllum.AddItem "A"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_A
    
    lbIllum.AddItem "B"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_B
    
    lbIllum.AddItem "C"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_C
    
    lbIllum.AddItem "D50"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_D50
    
    lbIllum.AddItem "D55"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_D55
    
    lbIllum.AddItem "D65"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_D65
    
    lbIllum.AddItem "D75"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_D75
    
    lbIllum.AddItem "DAYLIGHT"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_DAYLIGHT
    
    lbIllum.AddItem "DEVICE_DEFAULT"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_DEVICE_DEFAULT
    lbIllum.Selected(lbIllum.NewIndex) = True
    
    lbIllum.AddItem "F2"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_F2
    
    lbIllum.AddItem "FLUORESCENT"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_FLUORESCENT
    
    lbIllum.AddItem "MAX_INDEX"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_MAX_INDEX
    
    lbIllum.AddItem "NTSC"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_NTSC
    
    lbIllum.AddItem "TUNGSTEN"
    lbIllum.ItemData(lbIllum.NewIndex) = CA_ILLUMINANT.ILLUMINANT_TUNGSTEN
    
    ' Flag wenn die Form geladen wird
    isLoad = False
    
    Picture2.Picture = ColorAdjust(Picture1.Picture)
    
End Sub

Private Sub Change()

    Dim eFlags As CA_FLAGS
    
    ' erst wenn die Form fertig ist mit laden
    If Not isLoad Then
    
        eFlags = CA_DEFAULT
        
        If ckFlags(0).Value = 1 Then
            eFlags = eFlags Or CA_NEGATIVE
        End If
        
        If ckFlags(1).Value = 1 Then
            eFlags = eFlags Or CA_LOG_FILTER
        End If
        
        Picture2.Picture = ColorAdjust(Picture1.Picture, eFlags, lbIllum.ItemData( _
            lbIllum.ListIndex), CLng(scrColor(0).Value) * 2, CLng(scrColor( _
            1).Value) * 2, CLng(scrColor(2).Value) * 2, scrColor(3).Value, _
            scrColor(4).Value, scrColor(5).Value, scrColor(6).Value, scrColor( _
            7).Value, scrColor(8).Value)
            
    End If
    
End Sub

Private Sub ckFlags_Click(Index As Integer)

    Call Change
    
End Sub

Private Sub lbIllum_Click()

    Call Change
    
End Sub

Private Sub scrColor_Change(Index As Integer)

    Select Case Index
    
    Case 0, 1, 2
        lblVal(Index).Caption = CStr(CLng(scrColor(Index).Value) * 2)
        
    Case Else
        lblVal(Index).Caption = CStr(scrColor(Index).Value)
        
    End Select
    
    Call Change
    
End Sub

Private Sub scrColor_Scroll(Index As Integer)

    Call scrColor_Change(Index)
    
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--- Anfang Modul "modColorAdjustment" alias modColorAdjustment.bas ---
Option Explicit

' ----==== Const ====----
Private Const HALFTONE = 4

' ----==== Enums ====----
Public Enum CA_FLAGS
    CA_DEFAULT = &H0
    CA_NEGATIVE = &H1
    CA_LOG_FILTER = &H2
End Enum

Public Enum CA_ILLUMINANT
    ILLUMINANT_A = 1
    ILLUMINANT_B = 2
    ILLUMINANT_C = 3
    ILLUMINANT_D50 = 4
    ILLUMINANT_D55 = 5
    ILLUMINANT_D65 = 6
    ILLUMINANT_D75 = 7
    ILLUMINANT_DAYLIGHT = ILLUMINANT_C
    ILLUMINANT_DEVICE_DEFAULT = 0
    ILLUMINANT_F2 = 8
    ILLUMINANT_FLUORESCENT = ILLUMINANT_F2
    ILLUMINANT_MAX_INDEX = ILLUMINANT_F2
    ILLUMINANT_NTSC = ILLUMINANT_C
    ILLUMINANT_TUNGSTEN = ILLUMINANT_A
End Enum

' ----==== Types ====----
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Private Type COLORADJUSTMENT
    caSize As Integer
    caFlags As Integer
    caIlluminantIndex As Integer
    caRedGamma As Integer
    caGreenGamma As Integer
    caBlueGamma As Integer
    caReferenceBlack As Integer
    caReferenceWhite As Integer
    caContrast As Integer
    caBrightness As Integer
    caColorfulness As Integer
    caRedGreenTint As Integer
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

' ----==== GDI32 API Deklarationen ====----
Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _
                         ByVal hDC As Long, _
                         ByVal nWidth As Long, _
                         ByVal nHeight As Long) As Long
                         
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
                         ByVal hDC As Long) As Long
                         
Private Declare Function DeleteDC Lib "gdi32" ( _
                         ByVal hDC As Long) As Long
                         
Private Declare Function GetColorAdjustment Lib "gdi32" ( _
                         ByVal hDC As Long, _
                         ByRef lpca As COLORADJUSTMENT) As Long
                         
Private Declare Function GetObject Lib "gdi32" _
                         Alias "GetObjectA" ( _
                         ByVal hObject As Long, _
                         ByVal nCount As Long, _
                         ByRef lpObject As Any) As Long
                         
Private Declare Function GetStretchBltMode Lib "gdi32" ( _
                         ByVal hDC As Long) As Long
                         
Private Declare Function SelectObject Lib "gdi32" ( _
                         ByVal hDC As Long, _
                         ByVal hObject As Long) As Long
                         
Private Declare Function SetColorAdjustment Lib "gdi32" ( _
                         ByVal hDC As Long, _
                         ByRef lpca As COLORADJUSTMENT) As Long
                         
Private Declare Function SetStretchBltMode Lib "gdi32" ( _
                         ByVal hDC As Long, _
                         ByVal nStretchMode As Long) As Long
                         
Private Declare Function StretchBlt Lib "gdi32" ( _
                         ByVal hDC As Long, _
                         ByVal x As Long, _
                         ByVal y As Long, _
                         ByVal nWidth As Long, _
                         ByVal nHeight As Long, _
                         ByVal hSrcDC As Long, _
                         ByVal xSrc As Long, _
                         ByVal ySrc As Long, _
                         ByVal nSrcWidth As Long, _
                         ByVal nSrcHeight As Long, _
                         ByVal dwRop As Long) As Long
                         
' ----==== USER32 API Deklarationen ====----
Private Declare Function GetDC Lib "user32" ( _
                         ByVal hWnd As Long) As Long
                         
Private Declare Function ReleaseDC Lib "user32" ( _
                         ByVal hWnd As Long, _
                         ByVal hDC As Long) As Long
                         
' ----==== OLEOUT32 API Deklarationen ====----
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32" ( _
                    ByRef lpPictDesc As PICTDESC, _
                    ByRef riid As IID, _
                    ByVal fOwn As Boolean, _
                    ByRef lplpvObj As Object)
                    
' ---------------------------------------------------------------------
' Funktion     : ColorAdjust
' Beschreibung : Farbmanipulation per ColorAdjust-APIs (Min/Default/Max)
' Übergabewert : Pic = StdPicture
'                Flags = Enum CA_FLAGS
'                Illuminant = Enum CA_ILLUMINANT
'                RedGamma = Gammawert für Rot (2500/10000/65000)
'                GreenGamma = Gammawert für Grün (2500/10000/65000)
'                BlueGamma = Gammawert für Blau (2500/10000/65000)
'                RefBlack = Referenzwert für Schwarz (0/0/4000)
'                RefWhite = Referenzwert für Weiß (6000/10000/10000)
'                Contrast = Kontrast (-100/0/100)
'                Brightness = Helligkeit (-100/0/100)
'                Colorfulness = Farbsättigung (-100/0/100)
'                RedGreenTint = Rot/Grün (-100/0/100)
' Rückgabewert : StdPicture
' ---------------------------------------------------------------------
Public Function ColorAdjust(ByVal Pic As StdPicture, Optional ByVal Flags As _
    CA_FLAGS = CA_DEFAULT, Optional ByVal Illuminant As CA_ILLUMINANT = _
    ILLUMINANT_DEVICE_DEFAULT, Optional ByVal RedGamma As Long = 0, Optional ByVal _
    GreenGamma As Long = 0, Optional ByVal BlueGamma As Long = 0, Optional ByVal _
    RefBlack As Integer = 0, Optional ByVal RefWhite As Integer = 0, Optional ByVal _
    Contrast As Integer = 0, Optional ByVal Brightness As Integer = 0, Optional _
    ByVal Colorfulness As Integer = 0, Optional ByVal RedGreenTint As Integer = 0) _
    As StdPicture
    
    Dim lngDC As Long
    Dim hMemDC As Long
    Dim hMemDC1 As Long
    Dim hOldBmp As Long
    Dim hOldBmp1 As Long
    Dim hNewBmp As Long
    Dim lngBmpHeight As Long
    Dim lngBmpWidth As Long
    Dim tBITMAP As BITMAP
    Dim tCOLORADJUSTMENT As COLORADJUSTMENT
    
    ' Pic -> tBITMAP
    If GetObject(Pic.Handle, Len(tBITMAP), tBITMAP) <> 0 Then
    
        ' Höhe und Breite von Pic speichern
        lngBmpWidth = tBITMAP.bmWidth
        lngBmpHeight = tBITMAP.bmHeight
        
        ' einen DC ermitteln
        lngDC = GetDC(0&)
        
        ' ist ein DC vorhanden
        If lngDC <> 0 Then
        
            ' DC erstellen -> hMemDC
            hMemDC = CreateCompatibleDC(lngDC)
            
            ' ist ein DC vorhanden
            If hMemDC <> 0 Then
            
                ' Pic nach hMemDC
                hOldBmp = SelectObject(hMemDC, Pic)
                
                ' ist ein Handle vorhanden
                If hOldBmp <> 0 Then
                
                    ' Bitmap erstellen -> hNewBmp
                    hNewBmp = CreateCompatibleBitmap(lngDC, lngBmpWidth, lngBmpHeight)
                    
                    ' ist ein Handle vorhanden
                    If hNewBmp <> 0 Then
                    
                        ' DC erstellen -> hMemDC1
                        hMemDC1 = CreateCompatibleDC(lngDC)
                        
                        ' ist ein DC vorhanden
                        If hMemDC1 <> 0 Then
                        
                            ' hNewBmp nach hMemDC1
                            hOldBmp1 = SelectObject(hMemDC1, hNewBmp)
                            
                            ' ist ein Handle vorhanden
                            If hOldBmp1 <> 0 Then
                            
                                ' ColorAdjustment von hMemDC1 auslesen ->
                                ' tCOLORADJUSTMENT
                                If GetColorAdjustment(hMemDC1, tCOLORADJUSTMENT) <> _
                                    0 Then
                                    
                                    ' StretchBltMode von hMemDC1 ermitteln
                                    ' ist dieser <> HALFTONE dann
                                    If GetStretchBltMode(hMemDC1) <> HALFTONE Then
                                    
                                        ' StretchBltMode von hMemDC1 auf HALFTONE stellen
                                        If SetStretchBltMode(hMemDC1, HALFTONE) <> 0 Then
                                        
                                            ' Manipulieren der Werte in der
                                            ' tCOLORADJUSTMENT Stuktur
                                            With tCOLORADJUSTMENT
                                                .caSize = Len(tCOLORADJUSTMENT)
                                                .caFlags = Flags
                                                .caIlluminantIndex = Illuminant
                                                
                                                .caRedGamma = CheckVal(RedGamma, _
                                                    2500, .caRedGamma, 65000)
                                                    
                                                .caGreenGamma = CheckVal( _
                                                    GreenGamma, 2500, _
                                                    .caGreenGamma, 65000)
                                                    
                                                .caBlueGamma = CheckVal(BlueGamma, _
                                                    2500, .caBlueGamma, 65000)
                                                    
                                                .caReferenceBlack = CheckVal( _
                                                    RefBlack, 0, .caReferenceBlack, _
                                                    4000)
                                                    
                                                .caReferenceWhite = CheckVal( _
                                                    RefWhite, 6000, _
                                                    .caReferenceWhite, 10000)
                                                    
                                                .caContrast = CheckVal(Contrast, _
                                                    -100, .caContrast, 100)
                                                    
                                                .caBrightness = CheckVal( _
                                                    Brightness, -100, _
                                                    .caBrightness, 100)
                                                    
                                                .caColorfulness = CheckVal( _
                                                    Colorfulness, -100, _
                                                    .caColorfulness, 100)
                                                    
                                                .caRedGreenTint = CheckVal( _
                                                    RedGreenTint, -100, _
                                                    .caRedGreenTint, 100)
                                                    
                                            End With
                                            
                                            ' ColorAdjustment von hMemDC1 setzen
                                            If SetColorAdjustment(hMemDC1, _
                                                tCOLORADJUSTMENT) <> 0 Then
                                                
                                                ' zeichnet Pic in das neue Bitmap
                                                If StretchBlt(hMemDC1, 0, 0, _
                                                    lngBmpWidth, lngBmpHeight, _
                                                    hMemDC, 0, 0, lngBmpWidth, _
                                                    lngBmpHeight, vbSrcCopy) <> 0 _
                                                    Then
                                                    
                                                    ' StdPicture von hNewBmp erstellen
                                                    ' und zurückgeben
                                                    Set ColorAdjust = _
                                                        HandleToPicture(hNewBmp)
                                                        
                                                End If
                                            End If
                                        End If
                                    End If
                                End If
                                
                                ' alte Bitmap zurück
                                Call SelectObject(hMemDC1, hOldBmp1)
                                
                            End If
                            
                            ' hMemDC1 löschen
                            Call DeleteDC(hMemDC1)
                            
                        End If
                    End If
                    
                    ' alte Bitmap zurück
                    Call SelectObject(hMemDC, hOldBmp)
                    
                End If
                
                ' hMemDC löschen
                Call DeleteDC(hMemDC)
                
            End If
            
            ' lngDC freigeben
            Call ReleaseDC(0&, lngDC)
            
        End If
    End If
    
End Function

' ---------------------------------------------------------------------
' Funktion     : HandleToPicture
' Beschreibung : Umwandeln eines Bitmap Handle in ein StdPicture Objekt
' Übergabewert : hGDIHandle = Bitmap Handle
' Rückgabewert : StdPicture
' ---------------------------------------------------------------------
Private Function HandleToPicture(ByVal hGDIHandle As Long) As StdPicture

    Dim tPictDesc As PICTDESC
    Dim IID_IPicture As IID
    Dim oPicture As IPicture
    
    ' füllen der PICTDESC Struktur
    With tPictDesc
        .cbSizeOfStruct = Len(tPictDesc)
        .picType = vbPicTypeBitmap
        .hgdiObj = hGDIHandle
    End With
    
    ' füllen der IID_IPicture Struktur
    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
    
    ' Erstellen des IPicture-Objekts
    Call OleCreatePictureIndirect(tPictDesc, IID_IPicture, True, oPicture)
    
    ' Rückgabe des Picture-Objekts
    Set HandleToPicture = oPicture
    
End Function

' ---------------------------------------------------------------------
' Funktion     : CheckVal
' Beschreibung : Prüft ob Val in einem bestimmten Bereich liegt, wenn nicht
'                dann wird der Defaultwert zurückgegeben
' Übergabewert : Val = Value
'                Min = Minimalwert
'                Def = Defaultwert
'                Max = Maximalwert
' Rückgabewert : Wert in Integer
' ---------------------------------------------------------------------
Private Function CheckVal(ByVal Val As Long, ByVal Min As Long, ByVal Def As Long, _
    ByVal Max As Long) As Integer
    
    Dim lngRet As Long
    
    ' liegt Val außerhalb von Min/Max
    If Val < Min Or Val > Max Then
    
        ' Defaultwert zurückgeben
        lngRet = Def
    Else
    
        ' ansonsten Val zurückgeben
        lngRet = Val
    End If
    
    ' lngRet von Long nach Integer konvertieren
    lngRet = lngRet And &HFFFF&
    
    If lngRet > &H7FFF Then
        CheckVal = lngRet - &H10000
    Else
        CheckVal = lngRet
    End If
    
End Function
'--- Ende Modul "modColorAdjustment" alias modColorAdjustment.bas ---
'-------------- Ende Projektdatei Project1.vbp --------------