用VB编写一个屏幕颜色拾取器

原创 2004年07月07日 23:38:00

设计状态下窗口中添加两个Frame控件做为容器,加入二个PictureBox控件,一个PictureClip控件(其中装入一个设计好的鼠标指针Mask图片),两个文本框控件,几个Label控件,两个Command控件,一个CheckBox控件。

屏幕颜色拾取器

代码如下:

Option Explicit

Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
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 StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal Height 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
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Sub SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40

Private Type POINTAPI
        X As Long
        Y As Long
End Type

Private Const SRCCOPY = &HCC0020
Private Const SRCAND = &H8800C6
Private Const SRCPAINT = &HEE0086

Dim MousePos As POINTAPI
Dim oldMousePos As POINTAPI

Private Sub Check1_Click()
'设置顶层窗口
    If Check1.Value = 1 Then
        SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
    Else
        SetWindowPos Me.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
    End If
End Sub

Private Sub Command1_Click()
'开始停止捕捉屏幕
    If Command1.Caption = "停止" Then
        Command1.Caption = "开始"
        Timer1.Enabled = False
    Else
        Command1.Caption = "停止"
        Timer1.Enabled = True
    End If
End Sub

Private Sub Command2_Click()
'退出程序
    Unload Me
End Sub

Private Sub Form_Activate()
'程序启动后自动设置顶层窗口
    Check1.Value = 1
End Sub

Private Sub Timer1_Timer()
Dim WindowDC As Long
Dim Color As Long
Dim r As Integer, b As Integer, g As Integer
    GetCursorPos MousePos                                   '获取鼠标当前坐标
    'If MousePos.X = oldMousePos.X And MousePos.Y = oldMousePos.Y Then Exit Sub  '若未移动则返回
    Frame1.Caption = "坐标(" & MousePos.X & "," & MousePos.Y & ")"
    oldMousePos = MousePos
    WindowDC = GetWindowDC(0)                               '获取屏幕的设备场景
    Color = GetPixel(WindowDC, MousePos.X, MousePos.Y)      '获取鼠标所指点的颜色
    '分解RGB颜色值
    r = (Color Mod 256)
    b = (Int(Color / 65536))
    g = ((Color - (b * 65536) - r) / 256)
    Label1.BackColor = RGB(r, g, b)
    Text1.Text = r & "," & g & "," & b
    Text2.Text = WebColor(r, g, b)
    '将以鼠标位置为中心的9*9的屏幕图像放大
    StretchBlt Picture1.hDC, 0, 0, 73, 73, WindowDC, MousePos.X - 4, MousePos.Y - 4, 9, 9, SRCCOPY
    '将一个鼠标指针用Mask的方法透明的画到放大的图像中
    Picture2.Picture = PictureClip1.GraphicCell(1)
    BitBlt Picture1.hDC, 37, 37, 12, 21, Picture2.hDC, 0, 0, SRCAND
    Picture2.Picture = PictureClip1.GraphicCell(0)
    BitBlt Picture1.hDC, 37, 37, 12, 21, Picture2.hDC, 0, 0, SRCPAINT
    '获得是否按了热键F12
    If GetAsyncKeyState(vbKeyF12) <> 0 Then
        Timer1.Enabled = False
        Command1.Caption = "开始"
    End If
End Sub

Private Function WebColor(r As Integer, g As Integer, b As Integer) As String
'将10进制RGB值转为Web颜色值
    WebColor = "#" & INT2HEX(r) & INT2HEX(g) & INT2HEX(b)
End Function

Private Function INT2HEX(Value As Integer) As String
'10进制转16进制
    INT2HEX = Hex(Value)
    If Len(INT2HEX) = 1 Then
        INT2HEX = "0" & INT2HEX
    End If
End Function

运行效果:

屏幕颜色拾取器

vb调色板 调节RGB三原色 控制字体颜色 附源码

  • 2010年07月13日 09:10
  • 5KB
  • 下载

VB 自动获取颜色 代码

  • 2008年11月12日 21:12
  • 6KB
  • 下载

获取当前显示屏幕某一点的颜色

获取当前显示屏幕某一点的颜色 获取当前屏幕的截图 -(UIImage *)fullScreenshots{ UIWindow *screenWindow = [[UIApplication sh...
  • reylen
  • reylen
  • 2015年11月03日 09:57
  • 3465

VB.NET 章鱼哥 编程实现获取图片上任一点的RGB值

摘要:使用Bitmap类中的GetPixel(x,y)函数进行指定点颜色的获取,然后再分别获取R,G,B的值     新建一个空的窗体应用程序,在窗体Form1中添加一个Picturebox控件,一个...
  • zhangyubishoulin
  • zhangyubishoulin
  • 2015年04月14日 08:11
  • 1159

vb.net中彩色图像数据的快速获取

一直以来,图像处理都是VB的禁区,主要的原因可能是因为她没有指针,而图像的数据量通常都很大。其实,只要有正确的方法,VB同样可以写出高效而又快速的图像处理程序的。         我并不是学图像...
  • sdgaojian
  • sdgaojian
  • 2014年02月18日 11:26
  • 1172

屏幕颜色拾取器 V2.0.

  • 2009年08月06日 18:54
  • 1.84MB
  • 下载

屏幕颜色拾取器

  • 2017年03月29日 15:16
  • 1001KB
  • 下载

屏幕颜色拾取器(源码)

  • 2006年03月16日 00:00
  • 51KB
  • 下载

屏幕颜色拾取器

  • 2004年06月07日 00:00
  • 28KB
  • 下载

很好用的屏幕颜色拾取器

  • 2009年08月18日 15:58
  • 1.85MB
  • 下载
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:用VB编写一个屏幕颜色拾取器
举报原因:
原因补充:

(最多只允许输入30个字)