Looking To Get The Colour Of A Picture In Excel - excel

Question

I have a requirement where I need to get the colour of a picture in one of the cells.
Ideally I would like to do this via a piece of VBA Code, but I would be happy enough with a formula if one exists.
Please see attached screenshot.
In this scenario, I would like one of the following options
Replace Each of the Black Box Pictures with False and Replace the White Box Pictures with True
Have a formula that I could type into Column D which would describe the colour of the Picture.
Any help greatly appreciated.
Thanks,
Mark
Screenshot Of Example

Answer 1

This is a beast since we have to hit up a bunch of windows libraries to get the absolute position of the top-left of a cell, grab the pixel, figure out the color, and dump that back into the workbook.
I just did an "Assign Macro" to a picture in Cell D2 so when I click on it, this will stick that same color in Cell A1. You can monkey around with it to get it to do what you need, but all the necessary junk is here to do it.
#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 GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
#Else
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd 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 GetSystemMetrics Lib "user32.dll" (ByVal nIndex 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
#End If
Option Explicit
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
Private Function ScreenDPI(bVert As Boolean) As Long
'in most cases this simply returns 96
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
PTtoPX = Points * ScreenDPI(bVert) / 72
End Function
Private Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT)
Dim wnd As Window
'requires additional code to verify the range is visible
'etc.
Set wnd = rng.Parent.Parent.Windows(1)
With rng
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 CellColor(cellRange As Range)
Dim lColour As Long
Dim lDC As Variant
lDC = GetWindowDC(0)
'Grab the pixel that we will use to determine the color
Dim rc As RECT
Dim xPos As Integer
Dim yPos As Integer
Call GetRangeRect(cellRange, rc)
xPos = rc.Left
yPos = rc.Top
lColour = GetPixel(lDC, xPos, yPos)
Debug.Print xPos, yPos, lColour
Sheet1.Range("a1").Interior.Color = lColour
End Sub
Sub Picture1_Click()
CellColor Sheet1.Range("D2")
End Sub