使用GetDIBits()获取像素RGB颜色值

Question

我想使用GetDIBits()获得像素RGB颜色值。我已经可以使用GetPixel()获得像素RGB颜色值，但效率不是很高。我听说GetDIBits()在这方面做得更好。

运行时没有错误，但像素的RGB值始终为0。你能指出哪里出了问题吗？我不熟悉Windows API。

下面是我的代码：

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hdc 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 opCode As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal hdc 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

Const HORZRES As Integer = 8
Const VERTRES As Integer = 10

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 Double
  biClrUsed As Double
End Type
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type

Private Sub Form_Load()
    
    Dim hdc As Long
    Dim hDcmem As Long
    Dim hBmp As Long
    Dim oldBmp As Long
    Dim bmi As BITMAPINFO
    
    Dim OriginalImage() As Long
    
    Dim width As Long
    Dim height As Long
    
    Dim pixel As Long
    Dim r As Integer
    Dim b As Integer
    Dim g As Integer
   
    hdc = GetDC(0)
    hDcmem = CreateCompatibleDC(0)
    hBmp = CreateCompatibleBitmap(hdc, width, height)
    oldBmp = SelectObject(hDcmem, hBmp)

    width = GetDeviceCaps(hdc, HORZRES)
    height = GetDeviceCaps(hdc, VERTRES)
    
    ReDim OriginalImage(width - 1, height - 1)

    With bmi.bmiHeader
        .biBitCount = 32
        .biCompression = BI_RGB
        .biPlanes = 1
        .biWidth = width
        .biHeight = height
        .biSize = Len(bmi.bmiHeader)
    End With

    BitBlt hDcmem, 0, 0, width, height, hdc, 0, 0, vbSrcCopy
    GetDIBits hDcmem, hBmp, 0, height, OriginalImage(0, 0), bmi, DIB_RGB_COLORS

    pixel = OriginalImage(565, 1022) '<-the x, y coordinate of pixel requested
    r = pixel Mod 256
    g = ((pixel And &HFF00) / 256&) Mod 256&
    b = (pixel And &HFF0000) / 65536

    Debug.Print "Color is - r: " & r & " g: " & g & " b: " & b

    SelectObject hDcmem, oldBmp
    DeleteObject hBmp
    DeleteDC hDcmem
    ReleaseDC 0, hdc
    
End Sub

此代码基于this answer。

Answer 1

您在设置高度和宽度之前调用了CreateCompatibleBitmap函数。您的高度和宽度是0，所以您的hbmp永远不会包含数据。

未声明const BI_RGB和Const DIB_RGB_COLORS

您忽略了32位颜色的alpha通道，最好使用字节数组来捕获单个R G B颜色

尝试编辑如下所示的代码

Option Explicit

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hdc 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 opCode As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal hdc 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

Const HORZRES As Integer = 8
Const VERTRES As Integer = 10

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 Double
  biClrUsed As Double
End Type
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type

Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0

Private Sub Form_Load()
    
    Dim hdc As Long
    Dim hDcmem As Long
    Dim hBmp As Long
    Dim oldBmp As Long
    Dim bmi As BITMAPINFO
    
    Dim OriginalImage() As Byte
    
    Dim width As Long
    Dim height As Long
    
    
    Dim r As Byte
    Dim b As Byte
    Dim g As Byte
    Dim a As Byte
   
    hdc = GetDC(0)
    hDcmem = CreateCompatibleDC(0)

    width = GetDeviceCaps(hdc, HORZRES)
    height = GetDeviceCaps(hdc, VERTRES)
    
    ReDim OriginalImage(1 To 4, width - 1, height - 1)
    hBmp = CreateCompatibleBitmap(hdc, width, height)
    oldBmp = SelectObject(hDcmem, hBmp)

    With bmi.bmiHeader
        .biBitCount = 32
        .biCompression = BI_RGB
        .biPlanes = 1
        .biWidth = width
        ' Use negative height to scan top-down.
        .biHeight = -height
        .biSize = Len(bmi.bmiHeader)
    End With

    BitBlt hDcmem, 0, 0, width, height, hdc, 0, 0, vbSrcCopy
    GetDIBits hDcmem, hBmp, 0, height, OriginalImage(1, 0, 0), bmi, DIB_RGB_COLORS
    
    r = OriginalImage(1, 565, 1022)
    g = OriginalImage(2, 565, 1022)
    b = OriginalImage(3, 565, 1022)
    a = OriginalImage(4, 565, 1022)
    
    Debug.Print "Color is - r: " & r & " g: " & g & " b: " & b

    SelectObject hDcmem, oldBmp
    DeleteObject hBmp
    DeleteDC hDcmem
    ReleaseDC 0, hdc
    
End Sub