获取屏幕上某点的颜色（API实现）

musicbug

获取屏幕上某点的颜色（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

　

netghost

还有人用vb这种破东西么？

gaga

我偶尔也用
这里不少人也用，vb省事