Работа со скриншотом экрана в clipboard

SavePicture Clipboard.GetData(vbCFBitmap), "c:\1.bmp"

Open "c:\1.bmp" For Binary As 1
Get #1, ((900- y - 1) * 1600+ (x + 1)) * 3 + 55 , s
Close #1

Picture1.Picture = Clipboard.GetData
MsgBox Picture1.Point(10, 10)

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
 
Private Type RGBN
  R As Byte
  G As Byte
  B As Byte
  N As Byte
End Type
 
Private Sub Form_Load()
Dim c As RGBN
CopyMemory c, Picture1.Point(10, 10), 4
msgbox c.r,,"RED=" 'etc...
End Sub

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Color = GetPixel(Picture1.hdc, 10, 10) ' Средствами API

Option Explicit
 
Private Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER
  biSize As Long
  biWidth As Long
  biHeight As Long
  biPlanes As Integer
  biBitCount As Integer
  biCompression As Long
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type
Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
 
Private Sub Form_Load()
    Dim pix As RGBQUAD
    
    pix = GetPixelFromHBitmap(Clipboard.GetData().Handle, 390, 57)
    
    MsgBox "R: " & Hex(pix.rgbRed) & " G: " & Hex(pix.rgbGreen) & " B: " & Hex(pix.rgbBlue)
    
End Sub
 
Private Function GetPixelFromHBitmap( ByVal hBitmap As Long, ByVal x As Long, ByVal y As Long) As RGBQUAD
    Dim hdc As Long
    Dim info As BITMAPINFO
    Dim success As Boolean
    
    hdc = GetDC(0)
    
    info.bmiHeader.biSize = Len(info.bmiHeader)
    
    If GetDIBits(hdc, hBitmap, 0, 1, ByVal 0&, info, 0) Then
        
        If info.bmiHeader.biHeight > 0 Then
            
            y = info.bmiHeader.biHeight - y - 1
            
        End If
        
        Dim bits() As RGBQUAD
        
        ReDim bits(info.bmiHeader.biWidth - 1)
        
        info.bmiHeader.biBitCount = 32
        
        If GetDIBits(hdc, hBitmap, y, 1, bits(0), info, 0) Then
            
            GetPixelFromHBitmap = bits(x)
            success = True
            
        End If
        
    End If
    
    ReleaseDC 0, hdc
    
    If Not success Then
        Err.Raise 5
    End If
    
End Function

Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Sub Command1_Click()
    Dim dM, scrColor As Long
    scrColor = GetPixel(CreateDC("DISPLAY", vbNullString, vbNullString, dM), 10, 110)   'Да простит меня компилятор за игнорирование структуры DEVMODE, она слишком большая :)
    BackColor = scrColor 'проверяем
End Sub

Option Explicit
 
Private Const OBJ_BITMAP  As Long = 7
 
Private Type RGBQUAD
    rgbBlue         As Byte
    rgbGreen        As Byte
    rgbRed          As Byte
    rgbReserved     As Byte
End Type
Private Type BITMAPINFOHEADER
    biSize          As Long
    biWidth         As Long
    biHeight        As Long
    biPlanes        As Integer
    biBitCount      As Integer
    biCompression   As Long
    biSizeImage     As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed       As Long
    biClrImportant  As Long
End Type
Private Type BITMAPINFO
    bmiHeader       As BITMAPINFOHEADER
    bmiColors       As RGBQUAD
End Type
 
Private Declare Function GetDIBits Lib "gdi32" ( _
                         ByVal aHDC As Long, _
                         ByVal hBitmap As Long, _
                         ByVal nStartScan As Long, _
                         ByVal nNumScans As Long, _
                         ByRef lpBits As Any, _
                         ByRef lpBI As BITMAPINFO, _
                         ByVal wUsage As Long) As Long
Private Declare Function GetDC Lib "user32" ( _
                         ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
                         ByVal hwnd As Long, _
                         ByVal hDC As Long) As Long
Private Declare Function GetCurrentObject Lib "gdi32" ( _
                         ByVal hDC As Long, _
                         ByVal uObjectType As Long) As Long
 
Private Sub Form_Load()
    Dim tScreenshot()   As RGBQUAD
    
    If Not TakeScreenShot(tScreenshot()) Then
        MsgBox "TakeScreenShot failed"
        Exit Sub
    End If
    
    ' // В массиве tScreenshot все пиксели экрана.
    ' // Получаем доступ к 414;54
    
    MsgBox "R: " & Hex(tScreenshot(414, 54).rgbRed) & _
           " G: " & Hex(tScreenshot(414, 54).rgbGreen) & _
           " B: " & Hex(tScreenshot(414, 54).rgbBlue)
 
End Sub
 
Private Function TakeScreenShot( _
                 ByRef tBits() As RGBQUAD) As Boolean
    Dim hDC     As Long
    Dim hBmp    As Long
    Dim tBI     As BITMAPINFO
    
    hDC = GetDC(0)
    
    If hDC = 0 Then
        MsgBox "GetDC failed " & Err.LastDllError
        Exit Function
    End If
    
    hBmp = GetCurrentObject(hDC, OBJ_BITMAP)
    
    If hBmp = 0 Then
        MsgBox "GetCurrentObject failed " & Err.LastDllError
        GoTo CleanUp
    End If
    
    tBI.bmiHeader.biSize = Len(tBI.bmiHeader)
    
    If GetDIBits(hDC, hBmp, 0, 1, ByVal 0&, tBI, 0) = 0 Then
        MsgBox "GetDIBits failed " & Err.LastDllError
        GoTo CleanUp
    End If
 
    tBI.bmiHeader.biHeight = -Abs(tBI.bmiHeader.biHeight)
    tBI.bmiHeader.biBitCount = 32
    tBI.bmiHeader.biCompression = 0
    
    ReDim tBits(tBI.bmiHeader.biWidth - 1, (-tBI.bmiHeader.biHeight) - 1)
 
    If GetDIBits(hDC, hBmp, 0, -tBI.bmiHeader.biHeight, tBits(0, 0), tBI, 0) = 0 Then
        MsgBox "GetDIBits failed " & Err.LastDllError
        GoTo CleanUp
    End If
    
    TakeScreenShot = True
    
CleanUp:
    
    ReleaseDC 0, hDC
       
End Function