主题:获取屏幕上某点的颜色(API实现)
VB的Point函数可以获取程序窗体上任意像素点的颜色,但无法获得窗口之外的颜色,通过调用API函数,便可完成该任务,示例代码如下:
Option Explicit
'设备场景模式常数
Private Const CCHDEVICENAME As Long = 32
Private Const CCHFORMNAME As Long = 32
'鼠标光标结构
Private Type POINTAPI
X As Long
Y As Long
End Type
'设备场景模式结构
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
'创建设备场景句柄
Private Declare Function CreateDC _
Lib "gdi32" Alias "CreateDCA" ( _
ByVal lpDriverName As String, _
ByVal lpDeviceName As String, _
ByVal lpOutput As String, _
ByRef lpInitData As DEVMODE _
) As Long
'删除创建的设备场景句柄
Private Declare Function DeleteDC _
Lib "gdi32" ( _
ByVal hdc As Long _
) As Long
'获取当前鼠标屏幕位置
Private Declare Function GetCursorPos _
Lib "user32" ( _
ByRef lpPoint As POINTAPI _
) As Long
'获取像素点颜色
Private Declare Function GetPixel _
Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal X As Long, _
ByVal Y As Long _
) As Long
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim udtDevMode As DEVMODE
Dim udtPoint As POINTAPI
Dim hCurrentDc As Long
Dim lngColor As Long
'建立一个屏幕 DC
hCurrentDc = CreateDC("DISPLAY", vbNullString, vbNullString, udtDevMode)
If GetCursorPos(udtPoint) <> 0 Then
lngColor = GetPixel(hCurrentDc, udtPoint.X, udtPoint.Y)
Me.Line (0, 0)-(500, 500), lngColor, BF
End If
'不要忘记删除 DC
Call DeleteDC(hCurrentDc)
End Sub
Option Explicit
'设备场景模式常数
Private Const CCHDEVICENAME As Long = 32
Private Const CCHFORMNAME As Long = 32
'鼠标光标结构
Private Type POINTAPI
X As Long
Y As Long
End Type
'设备场景模式结构
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
'创建设备场景句柄
Private Declare Function CreateDC _
Lib "gdi32" Alias "CreateDCA" ( _
ByVal lpDriverName As String, _
ByVal lpDeviceName As String, _
ByVal lpOutput As String, _
ByRef lpInitData As DEVMODE _
) As Long
'删除创建的设备场景句柄
Private Declare Function DeleteDC _
Lib "gdi32" ( _
ByVal hdc As Long _
) As Long
'获取当前鼠标屏幕位置
Private Declare Function GetCursorPos _
Lib "user32" ( _
ByRef lpPoint As POINTAPI _
) As Long
'获取像素点颜色
Private Declare Function GetPixel _
Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal X As Long, _
ByVal Y As Long _
) As Long
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim udtDevMode As DEVMODE
Dim udtPoint As POINTAPI
Dim hCurrentDc As Long
Dim lngColor As Long
'建立一个屏幕 DC
hCurrentDc = CreateDC("DISPLAY", vbNullString, vbNullString, udtDevMode)
If GetCursorPos(udtPoint) <> 0 Then
lngColor = GetPixel(hCurrentDc, udtPoint.X, udtPoint.Y)
Me.Line (0, 0)-(500, 500), lngColor, BF
End If
'不要忘记删除 DC
Call DeleteDC(hCurrentDc)
End Sub