用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中利用API函数实现屏幕颜色数设定

  原则上,只改这一次,下一次开机会还原,但如果需重开机,才会Update Registry中的设定,并重开机。  如果要永久设定其设定值,请将b = ChangeDisplaySettings(De...
  • jevylau
  • jevylau
  • 2007年02月25日 10:43
  • 453

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

  • zgqtxwd
  • zgqtxwd
  • 2008年04月24日 08:46
  • 172

安卓Palette(颜色拾取)的使用

Palette是干嘛的? Palette是从Bitmap中提取颜色,然后可以把这个颜色设置给背景色、toolbar、TextView等等控件,使界面保持颜色风格统一协调。 效果预览: 动...
  • breeze_wf
  • breeze_wf
  • 2015年11月16日 15:43
  • 1107

用VC++开发一个屏幕颜色拾取器

0 && image.height>0){if(image.width>=700){this.width=700;this.height=image.height*700/image.width;}}...
  • yangyanghello
  • yangyanghello
  • 2013年11月18日 14:10
  • 620

屏幕颜色拾取器 (VC++)

系统环境:Windows 7软件环境:Visual C++ 2008 SP1本次目的:编写一个颜色拾取器      参考VC 知识库里面的一篇文章,以为网上的资料。自己动手试了下,下面是运行的界面:首...
  • akof1314
  • akof1314
  • 2009年11月26日 18:57
  • 3135

颜色拾取器(屏幕放大镜)

颜色拾取,屏幕放大等,功能强大,操作简单。
  • mycaibo
  • mycaibo
  • 2010年11月11日 10:46
  • 420

Chrome应用技巧之颜色拾取

之前在Chrome应用店找了个插件实现拾色功能,而且非常不理想。不知道是不是以前Chrome自带的开发工具没提供到拾色功能还是我没发现,今天无意中发现Chomer自带的开发工具可拾色,请看下面的GIF...
  • ioriliao
  • ioriliao
  • 2015年07月07日 18:03
  • 1535

如何在VB中执行屏幕捕捉并保存到指定位置

在很多情况下捕捉屏幕上的画面是非常有用的,比如:记录电脑失灵或者写技术手册和软件文档。你可以运用两种方法从VB程序中捕捉屏幕图片。一种是复杂的方法,包含windows的设备描述表和API组件,还有一种...
  • changleqy
  • changleqy
  • 2007年08月08日 15:32
  • 1879

Unity自定义UI组件(八) 颜色拾取器(上)

Unity UGUI自定组件 颜色拾取器 利用UGUI 实现颜色拾取器组件 - 1.无需任何asset - 2.导入代码即可生成 - 3.调用接口方便 其中涉及知识点: - 1.Unity截图 -...
  • qq_29579137
  • qq_29579137
  • 2017年07月04日 19:59
  • 1359

颜色拾取器color picker (javascript version)

颜色拾取器216种web safe color的构造方法var cl = [00,33,66,99,CC,FF];     var clist = [];     for(var r=0; r    ...
  • phdbrianlee
  • phdbrianlee
  • 2008年05月08日 14:34
  • 4222
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:用VB编写一个屏幕颜色拾取器
举报原因:
原因补充:

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