VB 5/6-Tipp 0791: Farbmanipulation per ColorAdjustment
von Frank Schüler
Beschreibung
Über die Get/SetColorAdjustment-APIs können diverse Farbmanipulationen an einem Bild vorgenommen werden. zb. Helligkeit, Kontrast, Farbsättigung, Gamma, Negativ, Tint ua. Recht flott auch bei großen Bildern
Schwierigkeitsgrad: | Verwendete API-Aufrufe: CreateCompatibleBitmap, CreateCompatibleDC, DeleteDC, GetColorAdjustment, GetDC, GetObjectA (GetObject), GetStretchBltMode, OleCreatePictureIndirect, ReleaseDC, SelectObject, SetColorAdjustment, SetStretchBltMode, StretchBlt | Download: |
'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 --------------
Tipp-Kompatibilität:
Windows/VB-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
VB4 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
VB5 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
VB6 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
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.