Get pixel RGB color values using GetDIBits()

Question

I want to get pixel RGB color values using GetDIBits(). I could already get pixel RGB color values using GetPixel(), but it is not very efficient. I hear GetDIBits() is better at this.

There is no error when running, but the RGB value of the pixels is always 0. Could you please point to what is wrong? I'm not familiar with the Windows API.

Here is my code:

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 code is based on this answer.

score 3 · Accepted Answer · edited May 18 '21 at 13:48

you have called CreateCompatibleBitmap function before settiing height and width . your height and width are 0 , so your hbmp will never contain data.

const BI_RGB and Const DIB_RGB_COLORS are not declared

you are ignoring alpha channel in 32 bit color and it is better to use byte array in capturing individual R G B color

Try Edited Code shown below

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

Thank you for your patient to check my code and point the problem, the code is running ok and the rgb variables return the value, but it looks the values are incorrect (check with screenshot in photoshop), and rgb values are just same (they shouldn't be). Could you please to check what's wrong with it? — user1928432, May 17 '21 at 13:49
hello there, with search and try, it looks fixed by change ```.biHeight = height``` to ```.biHeight = -height``` cause ```' Use negative height to scan top-down.``` now the rgb value return correct, thank you again, I mark your reply as anwser. Wish you everything fine. — user1928432, May 18 '21 at 07:07

Get pixel RGB color values using GetDIBits()

1 Answers1