Tipp 0255 Color Picker - 2 -
Autor/Einsender:
Datum:
  Michael Werner
13.07.2002
Entwicklungsumgebung:   VB 6
Mit dieser Erweiterung zu unserem Tipp Color Picker und unter Zuhilfenahme einiger API-Funktionen, ist es möglich mit Hilfe einer Pipette, ähnlich wie es in Grafikprogrammen verwendet wird, systemweit eine Farbe vom Desktop zu holen.
 
Option Explicit

Private Declare Function BitBlt Lib "gdi32" (ByVal _
        hDestDC 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 dwRop As Long) _
        As Long

Private Declare Function GetCursorPos Lib "user32" ( _
        lpPoint As POINTAPI) As Long

Private Declare Function GetDC Lib "user32" (ByVal _
        hWnd As Long) As Long

Private Declare Function GetPixel Lib "gdi32" (ByVal hDC _
        As Long, ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function ScreenToClient Lib "user32" ( _
        ByVal hWnd As Long, lpPoint As POINTAPI) As Long

Private Declare Function WindowFromPoint Lib "user32" ( _
        ByVal xPoint As Long, ByVal yPoint As Long) _
        As Long

Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd _
        As Long, ByVal hDC As Long) As Long

Private Type POINTAPI
  X As Long
  Y As Long
End Type

Private Sub Form_Load()
  Timer1.Interval = 50
  Timer1.Enabled = False
  Check(2).Value = vbChecked
End Sub

Private Sub Check_Click(Index As Integer)
  Dim i As Integer

  Select Case Index
     Case 0
      If Check(Index).Value = vbChecked Then
        Check(1).Value = vbUnchecked
        Check(2).Value = vbUnchecked
        Check(Index).Caption = "kopieren"
      Else
        Check(Index).Caption = ""
      End If

    Case 1
      If Check(Index).Value = vbChecked Then
        Check(0).Value = vbUnchecked
        Check(2).Value = vbUnchecked
        Check(Index).Caption = "kopieren"
      Else
        Check(Index).Caption = ""
      End If

    Case 2
      If Check(Index).Value = vbChecked Then
        Check(0).Value = vbUnchecked
        Check(1).Value = vbUnchecked
        Check(Index).Caption = "kopieren"
      Else
        Check(Index).Caption = ""
      End If
  End Select

  For i = 0 To 2
    If Check(i).Value = vbChecked Then
      Clipboard.Clear
      Clipboard.SetText Text(i).Text
    End If
  Next i
End Sub

Private Sub Timer1_Timer()
  Dim hWndp As Long, hDCp As Long, Result As Long, Pt As POINTAPI

  Static LastX As Long, LastY As Long

  Dim r As Byte, g As Byte, b As Byte
  Dim i As Integer

  Call GetCursorPos(Pt)
  If Pt.X = LastX And Pt.Y = LastY Then Exit Sub
  LastX = Pt.X
  LastY = Pt.Y

  hWndp = WindowFromPoint(Pt.X, Pt.Y)

  hDCp = GetDC(hWndp)

  Call ScreenToClient(hWndp, Pt)

  Result = GetPixel(hDCp, Pt.X, Pt.Y)
  If Result = -1 Then
    Call BitBlt(Picture1.hDC, 0, 0, 1, 1, hDCp, _
                  Pt.X, Pt.Y, vbSrcCopy)
    Result = Picture1.Point(0, 0)
  End If

  Call ReleaseDC(hWndp, hDCp)
  If Result = -1 Then Exit Sub
  Picture1.BackColor = Result

  Call RGBsplit(Result, r, g, b)

  Text(0).Text = Result
  Text(1).Text = "#" & CheckNull(Hex(r)) & CheckNull(Hex(g)) & _
        CheckNull(Hex(b))
  Text(2).Text = "RGB(" & r & ", " & g & ", " & b & ")"

  For i = 0 To 2
    If Check(i).Value = vbChecked Then
      Clipboard.Clear
      Clipboard.SetText Text(i).Text
    End If
  Next i
End Sub

Private Sub Picture2_MouseDown(Button As Integer, _
      Shift As Integer, X As Single, Y As Single)
  PipetteAn
End Sub

Private Sub Picture2_MouseUp(Button As Integer, _
      Shift As Integer, X As Single, Y As Single)
  PipetteAus
End Sub

Private Sub PipetteAn()
  Picture2.Visible = False
  MouseIcon = Picture2.Picture
  Form1.MousePointer = 99
  Screen.MousePointer = 99
  Timer1.Enabled = True
End Sub

Private Sub PipetteAus()
  Form1.Timer1.Enabled = False
  Form1.MousePointer = vbNormal
  Screen.MousePointer = vbNormal
  Form1.Picture2.Visible = True
End Sub

Private Sub RGBsplit(ByVal Col, r As Byte, g As Byte, b As Byte)
  b = (Col And 16711680) / 65536
  g = (Col And 65280) / 256
  r = Col And 255
End Sub

Private Function CheckNull(f As String)
  If Len(f) < 2 Then f = "0" & f
  CheckNull = f
End Function
 
Weitere Links zum Thema
Color Picker
RGB Farbanteile

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (3,6 kB) Downloads bisher: [ 1923 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Donnerstag, 8. September 2011