得到鼠标移动到地方的RGB颜色
主窗体代码:
程序代码: | [ 复制代码到剪贴板 ] |
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Sub Form_Load()
Timer1.Interval = 100
End Sub
Private Sub Timer1_Timer()
Dim tPOS As POINTAPI
Dim sTmp As String
Dim lColor As Long
Dim lDC As Long
lDC = GetWindowDC(0)
Call GetCursorPos(tPOS)
lColor = GetPixel(lDC, tPOS.X, tPOS.Y)
Label2.BackColor = lColor
sTmp = Right$("000000" & Hex(lColor), 6)
Text1.Text = "#" & sTmp
Label1.Caption = "R:" & Right$(sTmp, 2) & " G:" & Mid$(sTmp, 3, 2) & " B:" & Left$(sTmp, 2)
Text2(0).Text = xHexToDec(Right$(sTmp, 2))
Text2(1).Text = xHexToDec(Mid$(sTmp, 3, 2))
Text2(2).Text = xHexToDec(Left$(sTmp, 2))
Text3.Text = Text2(0).Text & "," & Text2(1).Text & "," & Text2(2).Text
Text2(3).Text = lColor
End Sub
Private Sub xStart_Click()
Timer1.Enabled = True
End Sub
Private Sub xStop_Click()
Timer1.Enabled = False
End Sub
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Sub Form_Load()
Timer1.Interval = 100
End Sub
Private Sub Timer1_Timer()
Dim tPOS As POINTAPI
Dim sTmp As String
Dim lColor As Long
Dim lDC As Long
lDC = GetWindowDC(0)
Call GetCursorPos(tPOS)
lColor = GetPixel(lDC, tPOS.X, tPOS.Y)
Label2.BackColor = lColor
sTmp = Right$("000000" & Hex(lColor), 6)
Text1.Text = "#" & sTmp
Label1.Caption = "R:" & Right$(sTmp, 2) & " G:" & Mid$(sTmp, 3, 2) & " B:" & Left$(sTmp, 2)
Text2(0).Text = xHexToDec(Right$(sTmp, 2))
Text2(1).Text = xHexToDec(Mid$(sTmp, 3, 2))
Text2(2).Text = xHexToDec(Left$(sTmp, 2))
Text3.Text = Text2(0).Text & "," & Text2(1).Text & "," & Text2(2).Text
Text2(3).Text = lColor
End Sub
Private Sub xStart_Click()
Timer1.Enabled = True
End Sub
Private Sub xStop_Click()
Timer1.Enabled = False
End Sub
十六进制转换成十进制
程序代码: | [ 复制代码到剪贴板 ] |
Attribute VB_Name = "xHex"
Function xHexToDec(xyz As String) As Integer
Dim x1 As String, x2 As String, DecX1 As Integer, DecX2 As Integer
x1 = Left(xyz, 1)
x2 = Right(xyz, 1)
Select Case x1
Case 0 To 9
DecX1 = Val(x1)
Case "A"
DecX1 = 10
Case "B"
DecX1 = 11
Case "C"
DecX1 = 12
Case "D"
DecX1 = 13
Case "E"
DecX1 = 14
Case "F"
DecX1 = 15
End Select
Select Case x2
Case 0 To 9
DecX2 = Val(x1)
Case "A"
DecX2 = 10
Case "B"
DecX2 = 11
Case "C"
DecX2 = 12
Case "D"
DecX2 = 13
Case "E"
DecX2 = 14
Case "F"
DecX2 = 15
End Select
xHexToDec = DecX1 * 16 + DecX2
End Function
Function xHexToDec(xyz As String) As Integer
Dim x1 As String, x2 As String, DecX1 As Integer, DecX2 As Integer
x1 = Left(xyz, 1)
x2 = Right(xyz, 1)
Select Case x1
Case 0 To 9
DecX1 = Val(x1)
Case "A"
DecX1 = 10
Case "B"
DecX1 = 11
Case "C"
DecX1 = 12
Case "D"
DecX1 = 13
Case "E"
DecX1 = 14
Case "F"
DecX1 = 15
End Select
Select Case x2
Case 0 To 9
DecX2 = Val(x1)
Case "A"
DecX2 = 10
Case "B"
DecX2 = 11
Case "C"
DecX2 = 12
Case "D"
DecX2 = 13
Case "E"
DecX2 = 14
Case "F"
DecX2 = 15
End Select
xHexToDec = DecX1 * 16 + DecX2
End Function
源文件下载地址:
[本日志由 田草 于 2007-06-20 09:33 PM 编辑]
|
田草 于 2007-09-14 10:40 PM 发表评论:
上面的程序十六进制的R值和B值倒过来了
发表评论 - 不要忘了输入验证码哦! |