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