Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0802: Farbeinstellungen einer Grafik mit StretchBlt ändern

VB 5/6-Tipp 0802: Farbeinstellungen einer Grafik mit StretchBlt ändern

 von Zardoz

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GetBrushOrgEx, GetColorAdjustment, SetBrushOrgEx, SetColorAdjustment, SetStretchBltMode, StretchBlt

Download: Download des Beispielprojektes [79,38 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 Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Horizontale Scrollbar "HScroll1" (Index von 0 bis 0)
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Beschriftungsfeld "Label1" (Index von 0 bis 0)
' Farbeinstellungen einer Grafik ändern

' Copyright © 2012 by Zardoz

Option Explicit

Private TwX As Single, TwY As Single
Private XD As Single, YD As Single
Private SW As Long, SH As Long
Private Dat1 As String
Private flgSkip As Boolean, flg1 As Boolean
Private OldAdjust As COLORADJUSTMENT
Private NewAdjust As COLORADJUSTMENT

Private Sub Form_Load()
' Einstellungen Form

  With Me
    .MousePointer = vbHourglass
    .ScaleMode = vbPixels
    .Caption = "Color-Adjustment"
    .WindowState = vbMaximized
    .KeyPreview = True
  End With
  
  TwX = Screen.TwipsPerPixelX
  TwY = Screen.TwipsPerPixelY
  flg1 = False

End Sub

Private Sub Form_Activate()
  
  If flg1 = True Then Exit Sub
  flg1 = True
  DoEvents
  
  Dat1 = App.Path & "\Race1.jpeg" ' Bildpfad hier einsetzen
  If Dir$(Dat1) = "" Then
    MsgBox "Datei nicht gefunden:" & vbCr & Dat1, _
      vbExclamation + vbOKOnly, App.Title
    Unload Me
    Exit Sub
  End If
  
  Call SetControls
  Call ResetColors
  
  Me.MousePointer = vbDefault

End Sub

Private Sub Command1_Click()
  ' Alle Einstellungen rückgängig
  
  Call ResetColors

End Sub

Private Sub SetControls()
  ' Controls laden, positionieren und Einstellungen setzen
  
  Dim TmpPic As StdPicture, Wert As Long
  Dim i As Long, XPos As Single, YPos As Single

  Set TmpPic = LoadPicture(Dat1)
  With Picture2
    .Visible = False
    .BorderStyle = vbBSNone
    .ScaleMode = vbPixels
    SW = Int(0.5 + .ScaleX(TmpPic.Width, vbHimetric))
    SH = Int(0.5 + .ScaleY(TmpPic.Height, vbHimetric))
    .Move 0, 0, SW, SH
    .AutoRedraw = True
    .PaintPicture TmpPic, 0, 0
    Call GetColorAdjustment(.hDC, OldAdjust)
  End With
  Set TmpPic = LoadPicture()
  
  With Frame1
    .BorderStyle = vbBSNone
    .BackColor = RGB(70, 70, 70)
    .Move 0, 0, Me.ScaleWidth - 408, Me.ScaleHeight
    .Visible = True
  End With
  
  With Picture1
    Set .Container = Frame1
    .BorderStyle = vbBSNone
    .ScaleMode = vbPixels
    .AutoRedraw = True
    .MousePointer = vbSizeAll
    .ZOrder vbBringToFront
    .Visible = True
  End With

  flgSkip = True
  For i = 0 To 8
    If i > 0 Then
      Load HScroll1(i)
      Load Label1(i)
    End If
    Load Label1(i + 9)
    XPos = Me.ScaleWidth - 400 - 4
    YPos = 4 + i * 48
    With Label1(i)
      .AutoSize = False
      .Move XPos + (400 - 60) / 2, YPos, 60
      .Alignment = vbCenter
      .Visible = True
    End With

    With Label1(i + 9)
      .Alignment = vbLeftJustify
      .AutoSize = True
      .Move XPos, YPos
      .Caption = Choose(i + 1, "Red Gamma", "Green Gamma", _
        "Blue Gamma", "Reference Black", "Reference White", _
        "Contrast", "Brightness", "Colorfulness", "Red Green Tint")
      .Visible = True
    End With
    
    With HScroll1(i)
      .Move XPos, YPos + Label1(0).Height, 400, 24
      
      Select Case i
        
        Case 0 To 2
          .Min = 250
          .Max = 6500
        Case 3
          .Min = 0
          .Max = 4000
        Case 4
          .Min = 6000
          .Max = 10000
        Case 5 To 8
          .Min = -100
          .Max = 100
      
      End Select
      
      .SmallChange = 1
      .LargeChange = (.Max - .Min + 1) \ 10
      .TabStop = False
      .Visible = True
    End With
  Next i
  
  Command1.Move XPos + (400 - 120) / 2, YPos + 60, 120
  Command1.Caption = "&Reset Colors"
  Command1.Visible = True
  
End Sub

Private Sub ResetColors()
  ' Alle Einstellungen rückgängig
  
  Dim i As Long, Wert As Long
  
  flgSkip = True
  With OldAdjust
    HScroll1(0).Value = CLng("&H" & Hex$(.caRedGamma)) / 10
    HScroll1(1).Value = CLng("&H" & Hex$(.caGreenGamma)) / 10
    HScroll1(2).Value = CLng("&H" & Hex$(.caBlueGamma)) / 10
    HScroll1(3).Value = .caReferenceBlack
    HScroll1(4).Value = .caReferenceWhite
    HScroll1(5).Value = .caContrast
    HScroll1(6).Value = .caBrightness
    HScroll1(7).Value = .caColorfulness
    HScroll1(8).Value = .caRedGreenTint
  End With

  For i = 0 To 8
    Label1(i).Caption = CStr(HScroll1(i).Value * IIf(i < 3, 10&, 1))
  Next i
  
  flgSkip = False
  NewAdjust = OldAdjust
  Picture1.Move (Frame1.Width - SW) / 2 * TwX, _
    (Frame1.Height - SH) / 2 * TwY, SW * TwX, SH * TwY
  Call DrawPicture

End Sub

Private Sub HScroll1_Change(Index As Integer)
  ' Event durchreichen
  
  Call HScroll1_Scroll(Index)

End Sub

Private Sub HScroll1_Scroll(Index As Integer)
  ' Geänderte Einstellungen eintragen und anzeigen
  
  Dim Wert As Long
  
  If flgSkip = True Then Exit Sub
  
  Wert = HScroll1(Index).Value
  If Index < 3 Then Wert = Wert * 10&
  Label1(Index).Caption = CStr(Wert)
  Label1(Index).Refresh
  
  With NewAdjust
    
    Select Case Index
      
      Case 0
        .caRedGamma = "&H" & Hex$(Wert)
      Case 1
        .caGreenGamma = "&H" & Hex$(Wert)
      Case 2
        .caBlueGamma = "&H" & Hex$(Wert)
      Case 3
        .caReferenceBlack = Wert
      Case 4
        .caReferenceWhite = Wert
      Case 5
        .caContrast = Wert
      Case 6
        .caBrightness = Wert
      Case 7
        .caColorfulness = Wert
      Case 8
        .caRedGreenTint = Wert
    
    End Select
    
  End With
  
  Call DrawPicture

End Sub

Private Sub DrawPicture()
  ' Grafik mit neuen Farbeinstellungen zeichnen
  
  Dim OldMode As Long, Pt As POINTAPI
  
  With Picture1
    ' Neue Farbeinstellungen setzen
    Call SetColorAdjustment(.hDC, NewAdjust)
    ' Koordinaten retten
    Call GetBrushOrgEx(.hDC, Pt)
    ' StretchBltMode setzen
    OldMode = SetStretchBltMode(.hDC, HALFTONE)
    ' Grafik mit aktuellen Farbeinstellungen zeichen
    Call StretchBlt(.hDC, 0, 0, SW, SH, _
      Picture2.hDC, 0, 0, SW, SH, vbSrcCopy)
    ' Alter StretchBltMode zurück
    Call SetStretchBltMode(.hDC, OldMode)
    ' Alte Koordinaten zurück
    Call SetBrushOrgEx(.hDC, Pt.x, Pt.y, Pt)
    ' Alte Farbeinstellungen zurück
    Call SetColorAdjustment(.hDC, OldAdjust)
    ' Neuzeichnen erzwingen
    .Refresh
  End With

End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
' Grafik verschieben Start
  
  XD = x
  YD = y
  Picture1.MousePointer = vbDefault

End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
' Grafik verschieben in Aktion
  
  If Button = vbLeftButton Then
    With Picture1
      .Move .Left + (x - XD) * TwX, .Top + (y - YD) * TwY
    End With
  End If

End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
' Grafik verschieben Ende

  Picture1.MousePointer = vbSizeAll

End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  ' Beenden mit Escape
  
  If KeyCode = vbKeyEscape Then Unload Me
  
End Sub

Private Sub Form_Unload(Cancel As Integer)
  ' Controls entladen
  
  Dim i As Long
  
  For i = 1 To HScroll1.UBound
    Unload HScroll1(i)
  Next i
  
  For i = 1 To Label1.UBound
    Unload Label1(i)
  Next i
  
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------
Option Explicit

' Typen
Public 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

Public Type POINTAPI
  x As Long
  y As Long
End Type

' Deklarationen
Public Declare Function SetColorAdjustment Lib "gdi32" (ByVal hDC As Long, lpca As COLORADJUSTMENT) As Long
Public Declare Function GetColorAdjustment Lib "gdi32" (ByVal hDC As Long, lpca As COLORADJUSTMENT) As Long
Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Public 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
Public Declare Function GetBrushOrgEx Lib "gdi32" (ByVal hDC As Long, lpPoint As POINTAPI) As Long
Public Declare Function SetBrushOrgEx Lib "gdi32" (ByVal hDC As Long, ByVal nXOrg As Long, ByVal nYOrg As Long, lppt As POINTAPI) As Long

' Konstanten
Public Const HALFTONE As Long = 4
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------