Handler for image object in GetPixel() API - function?

D

Dendro

Active Member
Joined
Jul 3, 2014
Messages
336
Hi,

I have searched but got stuck on correctly declaring and using the API function getpixel() in vba, hence i making a thread on this subject. I'm aware relevant post exist, but i failed to implement their solution.

What I would like to do: get the color of certain pixel of an image pasted in excel and assign it to a variable.

What I'm asking you:

1. What is the correct way of declaring a function without it giving the error: "comments are only allowed after End Sub, End Function and End Property". I'm using the following line which i found in other threads:

Code: 
Declare Function GetPixel Lib "gdi32" Alias GetPixel(ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

2. Could you comment on why all those parameters are there (why Byval, why do they create an Alias if it's the same name?)

3. hdc is the variable containing the handler for the image object. In the threads i found they use the following code to get the pixel at the pointer along with some other API, but I don't think I would need this one:

Code: 
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long

What image handler should i use (and why)?

(4. GetPixel returns 3 values as RGB, how would I be able to calculate with this, do i need to make 3 variables?)

It's quite technical, but i hope someone could help me with this. Thank you for your effort!

Dendro
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sort by date Sort by votes
What I would like to do: get the color of certain pixel of an image pasted in excel and assign it to a variable.
Click to expand...
What are the criteria for determining the required pixel point ? Is it the pixel under the mouse pointer or something else ?
 
Upvote 0
HI,

the pixel point would be defined by x and y coordinates which will be found under 2 separate variables, not under the mouse pointer.
 
Upvote 0
Here is this Function 'GetPixelColorFromExcelShape' which returns the color of a pixel based on two user input variables (x,y)

Place this code in a standard module :
Code: 
Option Explicit

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
Type POINTAPI
    x As Long
    y As Long
End Type
Type Size
    Width As Long
    Height As Long
End Type

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" _
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
 
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const CLR_INVALID = &HFFFF

Private Function GetPixelColorFromExcelShape(ByVal Shp As Shape, ByRef Pt As POINTAPI, ByRef WidthHeight As Size) As Long
    Dim oPic As StdPicture
    Set oPic = PicFromShape(Shp)
    If oPic <> 0 Then
        GetPixelColorFromExcelShape = PixelFromPoint(oPic, Pt, WidthHeight)
    End If
End Function

Private Function PixelFromPoint(ByVal Pic As StdPicture, ByRef Pt As POINTAPI, ByRef WidthHeight As Size) As Long
    Dim memDC As Long
    Dim tBm As BITMAP
    memDC = CreateCompatibleDC(0)
    Call SelectObject(memDC, Pic.Handle)
    Call GetObjectAPI(Pic.Handle, LenB(tBm), tBm)
    WidthHeight.Width = tBm.bmWidth - 1: WidthHeight.Height = tBm.bmHeight - 1
    PixelFromPoint = GetPixel(memDC, Pt.x, Pt.y)
    Call DeleteDC(memDC)
End Function

Private Function PicFromShape(Shp As Shape) As StdPicture
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As StdPicture
    Dim hPtr As Long
    Shp.CopyPicture xlScreen, xlBitmap
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    CloseClipboard
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPtr
        .hPal = 0
    End With
    OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
    Set PicFromShape = IPic
End Function

Here is an example that will get the color of the pixel x: 10 ; y: 30 from shape(1) on sheet1 .. Change the latters to meet your specific requirements :
Code: 
Sub Test()
    Dim lPixelColor
    Dim tPt As POINTAPI
    Dim tPicSize As Size
    tPt.x = 10
    tPt.y = 30
    lPixelColor = GetPixelColorFromExcelShape(Sheet1.Shapes(1), tPt, tPicSize)
    Select Case True
        Case tPicSize.Width = 0
            MsgBox "Unable to create picture"
        Case lPixelColor = -1
            MsgBox "Vriables outside range" & vbCr & 0 & "<= X <=" & tPicSize.Width & vbCr & 0 & "<= Y <=" & tPicSize.Height
        Case Else
            MsgBox "The color at Point : " & tPt.x & " - " & tPt.y & "  is : " & vbCr & vbCr & lPixelColor
    End Select
End Sub
 
Last edited:
Upvote 0
Very nice, ill try it in the near future. Could you give a short explanation on your approach? -> You are using the clipboard,why is this? Doesn't POINTAPI use the mouse coordinates?
 
Upvote 0
Dendro said:
Very nice, ill try it in the near future. Could you give a short explanation on your approach? -> You are using the clipboard,why is this? Doesn't POINTAPI use the mouse coordinates?
Click to expand...
Basically, what the code does is copy a picture of the shape to the clipboard so we can get the clipboard BITMAP pointer which can then be passed to the OleCreatePictureIndirect API .. This API returns a Picture Object in its 4th out parameter .. Once we have the shape Picture Object we can retrieve the Picture handle that is needed for the APIGetObject in order to get the picture size (Width/Height) in the memory DC
I would recommend you to read about all these API functions in the MS SDK .. Another good source of API examples worth visiting is AllAPI.net - Your #1 source for using API-functions in Visual Basic!

POINTAPI is a UDT variable (structure) and is often used to get the mouse coordinates but can be used for any other purpose .. In the case of the code I posted, it just holds the coordinates x & y of the Pixel we are trying to get the color of .. I could have used simple long variables instead of a UDT but I thought packing the Pixel coordinate variables inside a UDT is a more standard way
 
Upvote 0
Hi, Im trying to get this to work on Windows 8.1, with Excel 2010-64bit and found that I had to change
'Private Declare Function' to
'Private Declare PtrSafe Function' and
'olepro32.dll' to
'oleaut32.dll' before the macro would run, but it always responds "Unable to create Picture'.
Tried with a new document, pasted the text from Jaffar's two code boxes above into a Module and then used the top Insert menu to insert a 1200x1000px .jpg.

Any advice appreciated.
 
Upvote 0
Jaafar Tribak said:
Here is this Function 'GetPixelColorFromExcelShape' which returns the color of a pixel based on two user input variables (x,y)

Place this code in a standard module :
Code: 
Option Explicit

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
Type POINTAPI
    x As Long
    y As Long
End Type
Type Size
    Width As Long
    Height As Long
End Type

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" _
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long

Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const CLR_INVALID = &HFFFF

Private Function GetPixelColorFromExcelShape(ByVal Shp As Shape, ByRef Pt As POINTAPI, ByRef WidthHeight As Size) As Long
    Dim oPic As StdPicture
    Set oPic = PicFromShape(Shp)
    If oPic <> 0 Then
        GetPixelColorFromExcelShape = PixelFromPoint(oPic, Pt, WidthHeight)
    End If
End Function

Private Function PixelFromPoint(ByVal Pic As StdPicture, ByRef Pt As POINTAPI, ByRef WidthHeight As Size) As Long
    Dim memDC As Long
    Dim tBm As BITMAP
    memDC = CreateCompatibleDC(0)
    Call SelectObject(memDC, Pic.Handle)
    Call GetObjectAPI(Pic.Handle, LenB(tBm), tBm)
    WidthHeight.Width = tBm.bmWidth - 1: WidthHeight.Height = tBm.bmHeight - 1
    PixelFromPoint = GetPixel(memDC, Pt.x, Pt.y)
    Call DeleteDC(memDC)
End Function

Private Function PicFromShape(Shp As Shape) As StdPicture
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As StdPicture
    Dim hPtr As Long
    Shp.CopyPicture xlScreen, xlBitmap
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    CloseClipboard
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPtr
        .hPal = 0
    End With
    OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
    Set PicFromShape = IPic
End Function

Here is an example that will get the color of the pixel x: 10 ; y: 30 from shape(1) on sheet1 .. Change the latters to meet your specific requirements :
Code: 
Sub Test()
    Dim lPixelColor
    Dim tPt As POINTAPI
    Dim tPicSize As Size
    tPt.x = 10
    tPt.y = 30
    lPixelColor = GetPixelColorFromExcelShape(Sheet1.Shapes(1), tPt, tPicSize)
    Select Case True
        Case tPicSize.Width = 0
            MsgBox "Unable to create picture"
        Case lPixelColor = -1
            MsgBox "Vriables outside range" & vbCr & 0 & "<= X <=" & tPicSize.Width & vbCr & 0 & "<= Y <=" & tPicSize.Height
        Case Else
            MsgBox "The color at Point : " & tPt.x & " - " & tPt.y & "  is : " & vbCr & vbCr & lPixelColor
    End Select
End Sub
Click to expand...

@Jaafar Tribak This code is great! I'm trying to adapt it slightly for my purposes, but can't figure out where I'm going wrong.
I'm importing images into Excel, and trying to calculate the average colour for a user-defined area of the image. To do that, the user creates a boundary and then I loop through the screen pixels to see whether or not they fall within this boundary - if they do, then the RGB of that pixel is added to a collection before averaging out at the end.
I use the following code to record the XY coordinates of the mouse clicks that form the boundaries of the user-defined polygon, and would like to feed them into your code:

VBA Code: 
Dim Pnt As POINTAPI
GetCursorPos Pnt
Range("B2").Value = Pnt.X
Range("C2").Value = Pnt.Y

However your code takes a shape as its starting point and considers pixels in relation to that (e.g. in the test code, you had x=10 and y=30 from shape1); the XY coordinates I have aren't relative to a specific shape and take values such as X=-1110 and Y=815.

I'd be grateful if you could explain why these coordinate systems don't work together and how I can get it working.
 
Upvote 0
NatAes said:
@Jaafar Tribak This code is great! I'm trying to adapt it slightly for my purposes, but can't figure out where I'm going wrong.
I'm importing images into Excel, and trying to calculate the average colour for a user-defined area of the image. To do that, the user creates a boundary and then I loop through the screen pixels to see whether or not they fall within this boundary - if they do, then the RGB of that pixel is added to a collection before averaging out at the end.
I use the following code to record the XY coordinates of the mouse clicks that form the boundaries of the user-defined polygon, and would like to feed them into your code:

VBA Code: 
Dim Pnt As POINTAPI
GetCursorPos Pnt
Range("B2").Value = Pnt.X
Range("C2").Value = Pnt.Y

However your code takes a shape as its starting point and considers pixels in relation to that (e.g. in the test code, you had x=10 and y=30 from shape1); the XY coordinates I have aren't relative to a specific shape and take values such as X=-1110 and Y=815.

I'd be grateful if you could explain why these coordinate systems don't work together and how I can get it working.
Click to expand...

Hi NatAes and welcome to the forum.

The X and Y coordinates are supposed to be between 0 and the image width or the image height respectively. I don't see how X can be a negative value.

And do the images you are importing into excel end up as shapes\objects embeeded in a worksheet ? or is it something else ?

Regards.
 
Upvote 0
Thanks @Jaafar Tribak.

I've just realised how I'm getting negative numbers...its using the POINTAPI to detect the screen pixel coordinates, and I have a 2-screen setup - with my main screen being the one on the right. So given the top left of the right-hand side screen is 0,0, anything to the left of that (i.e. on my second screen) gets a negative X-coordinate. I can fix this though and just switch the screens around.
However its clear that its getting the pixels relative to the screen and not relative to the shape, and hence the coordinates won't be between 0 and the image width / height. How can I click on a point on the image and get the coordinates for that point relative to the shape?

To answer the second question, I am importing the images as shapes through VBA using this code (where ImageURL is a URL stored in the sheet):
VBA Code: 
Set shp = Sheets("Sheet1").Shapes.AddPicture(ImageURL, msoFalse, msoTrue, clLeft, clTop, 343, 343)
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
310
Minh Tuan VN
M
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
750
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
0
Views
172
Jaafar Tribak
Jaafar Tribak
T
  • Solved
Chart point must move to point of click in chart
Replies
2
Views
587
tigger_na
T
Jaafar Tribak
  • Question Question
Blurring images using Direct2D & Windows Imaging Component
Replies
3
Views
777
Dan_W
D

Forum statistics

Threads
1,223,268
Messages
6,171,100
Members
452,379
Latest member
IainTru

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top