4

There is a near exact question here Read pixel colors of an image

The Op actually asks the same question as I'm asking for. But accepts an answer that is nearly there but not quite.. The code below (taken from that thread) does everything I need bar the pixel by pixel bit. If you click on an image it will give you the colour at the click site. As I want to scan the whole picture I though I'd just do an X Y scan and put the sequential X and Y's in instead of the returned X and Y of the GetCursorPos call. But how to get left position and width (for example) in pixels to start the scan? What would I put in my for next loop to address each pixel ?

So to clarify my question. How to change the code below to scan every pixel of the image not just the clicked cursor position. Thanks

#If VBA7 Then
    Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As LongPtr
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
#Else
    Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long,     ByVal y As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
    Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
#End If
Private Type POINT
    x As Long
    y As Long
End Type

Sub Picture1_Click()
    Dim pLocation As POINT
    Dim lColour As Long

    Dim lDC As Variant
    lDC = GetWindowDC(0)
    Call GetCursorPos(pLocation)
    lColour = GetPixel(lDC, pLocation.x, pLocation.y)
    Range("a1").Interior.Color = lColour
End Sub
7
  • 1
    Your question is really about mapping coordinate systems. This is absolutely nothing to do with reading pixels. This question would be so much more useful if it had been properly abstracted into what it is. Commented Sep 1, 2017 at 11:28
  • Thanks for your constructive comments.. However may I point out If you don't know the answer then you can just say I don't know or ignore the question. You don't need to make a comment which is of no use to man or beast. Marking down the question for no valid reason isn't conducive to the learning environment that stackoverflow is..
    – perfo
    Commented Sep 1, 2017 at 11:39
  • It's not clear at all to me what range of screen coordinates you are looking for. Commented Sep 1, 2017 at 13:43
  • My aim is to have an image (can be any format BMP,JPEG etc) I can control the format. In VBA I want to scan through each pixel of the picture and extract the colour information for each pixel. The other thread I reference above does part of this by inserting the image on to an excel sheet and using the cursor position to identify the pixel the user requires. I can seem to find how to locate the top left of the image in pixels to then scan the whole image. Image.left gives me the coordinates in Twips (I think) but I have no luck with using getpixcel(HDc,X,Y) as the x y here is in pixels.
    – perfo
    Commented Sep 1, 2017 at 13:55
  • Sorry I should have added. Getting the pixel colour from an image in VBA is my ultimate aim. I would be very willing to do it anyway that works. The above code seemed to be a good place for me to start. Thanks David
    – perfo
    Commented Sep 1, 2017 at 13:57

2 Answers 2

6
Option Explicit

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 GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long


Private Type RECT
  Left As Long
  Top  As Long
  Right As Long
  Bottom As Long
End Type

Private Type POINTAPI
    X As Long
    Y As Long
End Type
Dim IDC As Long

Private Function ScreenDPI(bVert As Boolean) As Long
  '*** Get screen DPI ***
  Static lDPI&(1), lDC&
  If lDPI(0) = 0 Then
    lDC = GetDC(0)
    lDPI(0) = GetDeviceCaps(lDC, 88&)    'horz
    lDPI(1) = GetDeviceCaps(lDC, 90&)    'vert
    lDC = ReleaseDC(0, lDC)
  End If
  ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
'*** Swap Points to pixels ****
  PTtoPX = Points * ScreenDPI(bVert) / 72
End Function
Sub GetImageRect(ByRef RC As RECT)
Dim RNG As Range
Set RNG = Sheet1.Range("A1")

'**** using the spread sheet cell A1 as a reference ***
'** find the details of th eimage and convert to pixels ***
  Dim wnd As Window
  Set wnd = RNG.Parent.Parent.Windows(1)
  With Sheet1.Image1
    RC.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) + wnd.PointsToScreenPixelsX(0)
    RC.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) + wnd.PointsToScreenPixelsY(0)
    RC.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) + RC.Left
    RC.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) + RC.Top
  End With
End Sub

Sub XYScanOfImage()
'*** put an active X image on sheet1 call it image1 and run this routine **
'** to get the colour information for each pixel *****
Dim RC As RECT
Dim ScanX As Single
Dim ScanY As Single
Dim ImX As Single
Dim ImY As Single
Dim PixCol As Single

Call GetImageRect(RC)
ImX = RC.Left
ImY = RC.Top

IDC = GetDC(0)
'*** scan image left to right top to bottom ****
For ScanX = RC.Left To RC.Right
  For ScanY = RC.Top To RC.Bottom
    PixCol = GetPixel(IDC, ScanX, ScanY)
    '**** PUT CODE IN HERE TO PROCESS THE PIXEL COLOUR ****
  Next
Next
IDC = ReleaseDC(0, IDC)
End Sub
4
  • So the above is not pretty but does exactly what I wanted and in VBA as desired. To test it just insert an active x image in to sheet1 and ensure it is called image1 then run the XYScanofImage routine.
    – perfo
    Commented Sep 1, 2017 at 16:37
  • Why the -1 ?? This was my own question and the answer is perfect for what I need. If you are going to do a -1 at least let me know why. Maybe your comments would actually help someone...
    – perfo
    Commented Sep 2, 2017 at 14:29
  • Hey man thank you. It worked perfectly. I found this tool as well it makes the job faster! Commented Apr 6, 2018 at 18:52
  • unfortunately this only works if the image is added to the sheet. What if it were external? Commented Oct 27, 2019 at 21:35
0

The answer from perfo is fantastic - and works!

Some notes to help:

  1. You have to add the image as an ActiveX control (go to the Excel Developer ribbon to to do this, then right-click on the image and set its name to Image1 - this should be the default anyway).
  2. Also, make sure it's on a sheet called Sheet1 in VBA (again, this should be the default).

The routine returns an RGBA colour. I created the following routine to colour each cell:

Sub ColourCell(c As Range, ThisColour As Single)

'colour the passed in range

Dim Red As Byte
Dim Green As Byte
Dim Blue As Byte

Red = ThisColour And &HFF&
Green = (ThisColour And &HFF00&) / 256
Blue = (ThisColour And &HFF0000) / 65535

c.Interior.Color = RGB(Red, Green, Blue)

End Sub

I amended the answer to colour the cells from the active cell down and across as follows:

'*** scan image left to right top to bottom ****
Dim i As Integer
Dim j As Integer

Dim OriginalRowNumber As Integer
Dim OriginalColumnNumber As Integer

OriginalRowNumber = ActiveCell.Row
OriginalColumnNumber = ActiveCell.Column

i = OriginalRowNumber
j = OriginalColumnNumber

Sheet1.Select

Cells.EntireColumn.ColumnWidth = 0.63
Cells.EntireRow.RowHeight = 6

For ScanX = RC.Left To RC.Right
  For ScanY = RC.Top To RC.Bottom
    PixCol = GetPixel(IDC, ScanX, ScanY)
    ColourCell Cells(j, i), PixCol
    j = j + 1
    
  Next
  i = i + 1
  
  If i Mod 5 = 0 Then Stop
  
  j = OriginalColumnNumber
  
Next

There are a couple of extra bits in there to set a tiny grid size, so you can see your picture unfolding, and a debug line to pause the macro every 5 columns (it takes a LONG time to run).

1
  • One other warning (may be obvious to others, but I didn't really understand how the Windows calls worked) - if you try to do something else while your macro is running, it will pick up on your new screen and switch what it's drawing!
    – Andy Brown
    Commented Aug 22, 2020 at 15:38

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.