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

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
Sort by date Sort by votes
Ok - Here is the amended code for mixing paints :

Workbook Example


ImagePicker2.gif




1- API code in a Standard Module:
VBA Code: 
Option Explicit

Public Enum CursorTypes
    OCR_ARROW = 32512
    IDC_CROSS = 32515
    IDC_HAND = 32649
End Enum

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Type Size
    Width As Long
    Height As Long
End Type

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

Private Type RGB
    R As Long
    G As Long
    B As Long
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    #If VBA7 Then
        bmBits As LongPtr
    #Else
        bmBits As Long
    #End If
End Type

Private Type LOGPEN
    lopnStyle As Long
    lopnWidth As POINTAPI
    lopnColor As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

 #If VBA7 Then
    #If Win64 Then
            Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
            Private Declare PtrSafe Function DragDetect Lib "user32" (ByVal hwnd As LongPtr, ByVal Pt As LongLong) As Long
    #Else
            Private Declare PtrSafe Function DragDetect Lib "user32.DLL" (ByVal hwnd As LongPtr, Pt As POINTAPI) As Long
    #End If
    Private Declare PtrSafe Function GetCursorPos Lib "user32.DLL" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function CopyIcon Lib "user32" (ByVal hIcon As LongPtr) As LongPtr
    Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
    Private Declare PtrSafe Function SetSystemCursor Lib "user32" (ByVal hCur As LongPtr, ByVal id As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function EnableWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal fEnable As Long) As Long
    Private Declare PtrSafe Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetROP2 Lib "gdi32" (ByVal hDC As LongPtr, ByVal nDrawMode As Long) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function Rectangle Lib "gdi32" (ByVal hDC As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    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 GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    
    Private hDC As LongPtr, hInitMemDC As LongPtr, hInitMemBmp As LongPtr, hwnd As LongPtr

#Else
    Private Declare Function DragDetect Lib "user32.DLL" (ByVal hwnd As Long, Pt As POINTAPI) As Long
    Private Declare Function GetCursorPos Lib "user32.DLL" (lpPoint As POINTAPI) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function CopyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
    Private Declare Function SetSystemCursor Lib "user32" (ByVal hCur As Long, ByVal id As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
    Private Declare Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase 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 CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
    Private Declare Function SetROP2 Lib "gdi32" (ByVal hDC As Long, ByVal nDrawMode 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 BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
    Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    
    Private hDC As Long, hInitMemDC As Long, hInitMemBmp As Long, hwnd As Long

#End If


Private eMousePt As CursorTypes
Private tStartPt As POINTAPI
Private oPicCtrl As Object, oUF As Object, oPic As IPicture
Private lScrwidth As Long, lScrHeight As Long
Private lTotalColors As Long
Private bDragging As Boolean, bExitLoop As Boolean




Public Sub SelectSectionOfTheScreen(ByVal Form As Object, ByVal PicHolder As Object)

    Const SM_CXSCREEN = 0
    Const SM_CYSCREEN = 1
    Const SRCCOPY As Long = &HCC0020
    Const SPI_SETCURSORS = 87

    Set oUF = Form
    Set oPicCtrl = PicHolder
    bExitLoop = False
    bDragging = False
    tStartPt.X = 0
    tStartPt.Y = 0
    lTotalColors = 0
    
    Call WindowFromAccessibleObject(Form, hwnd)
    Call EnableWindow(Application.hwnd, 0)
    Call SystemParametersInfo(SPI_SETCURSORS, 0, 0, 0)
    SystemCursor = eMousePt
    lScrwidth = GetSystemMetrics(SM_CXSCREEN): lScrHeight = GetSystemMetrics(SM_CYSCREEN)
    hDC = GetDC(0)
    hInitMemDC = CreateCompatibleDC(hDC)
    hInitMemBmp = CreateCompatibleBitmap(hDC, lScrwidth, lScrHeight)
    Call SelectObject(hInitMemDC, hInitMemBmp)
    Call BitBlt(hInitMemDC, 0, 0, lScrwidth, lScrHeight, hDC, 0, 0, SRCCOPY)
    Call MonitorMouseDragging

End Sub


Public Function CalculateAverageColor() As Long

    #If VBA7 Then
        Dim hScrDC As LongPtr, hMemDC As LongPtr
    #Else
        Dim hScrDC As Long, hMemDC As Long
    #End If
    
    Dim aRed() As Integer
    Dim aGreen() As Integer
    Dim aBlue() As Integer
    Dim lRow As Long, lCol As Long, lPix As Long
    Dim iNew_R As Integer, iNew_G As Integer, iNew_B As Integer
    Dim tBm As BITMAP, tSize As Size
    Dim lCurPixel As Long, oCol As Collection
    
    Call GetObjectAPI(oPicCtrl.Picture.handle, LenB(tBm), tBm)
    tSize.Width = tBm.bmWidth - 1: tSize.Height = tBm.bmHeight - 1
    hScrDC = GetDC(0)
    hMemDC = CreateCompatibleDC(hScrDC)
    Call ReleaseDC(0, hScrDC)
    Call SelectObject(hMemDC, oPicCtrl.Picture.handle)
    
    Application.EnableCancelKey = xlErrorHandler
    On Error Resume Next
    
    Set oCol = New Collection
    For lRow = 1 To tSize.Width
        For lCol = 1 To tSize.Height
            If GetAsyncKeyState(VBA.vbKeyEscape) Then GoTo Err_
            lCurPixel = GetPixel(hMemDC, lRow, lCol)
                ReDim Preserve aRed(lPix)
                ReDim Preserve aGreen(lPix)
                ReDim Preserve aBlue(lPix)
                aRed(lPix) = ColorToRGB(lCurPixel).R
                aGreen(lPix) = ColorToRGB(lCurPixel).G
                aBlue(lPix) = ColorToRGB(lCurPixel).B
                oCol.Add lCurPixel, CStr(lCurPixel)
                lPix = lPix + 1
                'DoEvents
        Next lCol
    Next lRow

   iNew_R = WorksheetFunction.Sum(aRed) / lPix
   iNew_G = WorksheetFunction.Sum(aGreen) / lPix
   iNew_B = WorksheetFunction.Sum(aBlue) / lPix
    
    lTotalColors = oCol.Count
    CalculateAverageColor = RGB(iNew_R, iNew_G, iNew_B)

Err_:

     Call DeleteDC(hMemDC)
     Call MakeNormal

End Function


Public Property Let Mouse_Pointer(ByVal MousePt As CursorTypes)
    eMousePt = MousePt
End Property


Public Property Get GetTotalColors() As Long
    GetTotalColors = lTotalColors
End Property


Public Sub MakeTopMost(ByVal OnTop As Boolean)

    Const HWND_TOPMOST = -1
    
    If OnTop Then
        SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, 3
    Else
        Application.OnTime Now, "MakeNormal"
    End If

End Sub




'======================== Supporting Private Routines================================

Private Sub MakeNormal()

    Const HWND_NOTOPMOST = -2
    
    SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, 3
 
End Sub


Private Sub MonitorMouseDragging()

    #If VBA7 Then
        Dim hCanvasDc As LongPtr, hCanvasBmp As LongPtr, hSelectedDC As LongPtr, hSelectedMemBmp As LongPtr
        Dim hOldPen As LongPtr, hPen As LongPtr
    #Else
        Dim hCanvasDc As Long, hCanvasBmp As Long, hSelectedDC As Long, hSelectedMemBmp As Long
        Dim hOldPen As Long, hPen As Long
    #End If
    
    Const R2_NOTXORPEN = 10
    Const PS_SOLID = 0
    Const SRCCOPY As Long = &HCC0020
    Const SPI_SETCURSORS = 87
    
     Dim tSelectedAreaRect As RECT, tCurPos As POINTAPI, tPen As LOGPEN
     Dim bOutsideXL As Boolean
    
    Application.EnableCancelKey = xlErrorHandler
    On Error GoTo Xit
    
    Do
    
    If GetActiveWindow <> Application.hwnd Then bOutsideXL = True: GoTo Xit
    
    Call GetCursorPos(tCurPos)
    #If Win64 Then
        Dim lPt As LongPtr
        Call CopyMemory(lPt, tCurPos, LenB(lPt))
        If DragDetect(Application.hwnd, lPt) Then
    #Else
        If DragDetect(Application.hwnd, tCurPos) Then
    #End If
            bDragging = True
            If tStartPt.X = 0 Then Call GetCursorPos(tStartPt)
            With tSelectedAreaRect
                .Left = tStartPt.X
                .Top = tStartPt.Y
                .Right = tCurPos.X
                .Bottom = tCurPos.Y
                hCanvasDc = CreateCompatibleDC(hDC)
                Call SetROP2(hCanvasDc, R2_NOTXORPEN)
                hCanvasBmp = CreateCompatibleBitmap(hDC, lScrwidth, lScrHeight)
                Call SelectObject(hCanvasDc, hCanvasBmp)
                With tPen
                    .lopnColor = vbRed
                    .lopnWidth.X = 2
                    .lopnWidth.Y = 10
                    .lopnStyle = PS_SOLID
                End With
                hPen = CreatePenIndirect(tPen)
                hOldPen = SelectObject(hCanvasDc, hPen)
                Call BitBlt(hCanvasDc, 0, 0, lScrwidth, lScrHeight, hInitMemDC, 0, 0, SRCCOPY)
                Call Rectangle(hCanvasDc, .Left, .Top, .Right, .Bottom)
                Call BitBlt(hDC, 0, 0, lScrwidth, lScrHeight, hCanvasDc, 0, 0, SRCCOPY)
                hSelectedDC = CreateCompatibleDC(hDC)
                hSelectedMemBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
                Call SelectObject(hSelectedDC, hSelectedMemBmp)
                Call BitBlt(hSelectedDC, 0, 0, .Right - .Left, .Bottom - .Top, hInitMemDC, .Left, .Top, SRCCOPY)
                Set oPic = CreateStdPicture(hSelectedMemBmp)
                Call DeleteDC(hCanvasDc)
                Call DeleteObject(hCanvasBmp)
                Call DeleteDC(hSelectedDC)
                Call DeleteObject(hSelectedMemBmp)
                Call DeleteObject(hOldPen)
            End With
        Else
            If bDragging Then
                GoTo Xit
            End If
        End If
        
        If bExitLoop Then GoTo Xit
        DoEvents
        
    Loop

    Exit Sub

Xit:

    Call ReleaseDC(0, hDC)
    Call DeleteDC(hInitMemDC)
    Call DeleteObject(hInitMemBmp)
    bDragging = False
    bExitLoop = True
    Call EnableWindow(Application.hwnd, 1)
    Call SystemParametersInfo(SPI_SETCURSORS, 0, 0, 0)
    Call InvalidateRect(0, 0, 0)
    Set oPicCtrl.Picture = oPic
    If bOutsideXL = False Then oUF.Show
    Call MakeNormal
    Set oPicCtrl = Nothing
    Set oUF = Nothing
    Set oPic = Nothing
    
End Sub


#If VBA7 Then
    Private Function CreateStdPicture(ByVal BMP As LongPtr) As IPicture
        Dim hCopy As LongPtr
#Else
    Private Function CreateStdPicture(ByVal BMP As Long) As IPicture
        Dim hCopy As Long
#End If

    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const LR_COPYRETURNORG = &H4
    Const S_OK = &H0
    
    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc, iPic As IPicture
    
    hCopy = CopyImage(BMP, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    
    With IID_IDispatch
       .Data1 = &H20400
       .Data4(0) = &HC0
       .Data4(7) = &H46
    End With
    
    With uPicinfo
       .Size = Len(uPicinfo)
       .Type = PICTYPE_BITMAP
       .hPic = hCopy
       .hPal = 0
    End With
    
    If OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, iPic) = S_OK Then
       Set CreateStdPicture = iPic
    End If

End Function


Private Property Let SystemCursor(ByVal CurID As CursorTypes)

    #If VBA7 Then
        Dim hIcon As LongPtr
    #Else
        Dim hIcon As Long
    #End If

    Dim arCurs As Variant, i As Long

    arCurs = Array(OCR_ARROW, IDC_CROSS, IDC_HAND)

    For i = LBound(arCurs) To UBound(arCurs)
        hIcon = CopyIcon(LoadCursor(0&, CurID))
        If hIcon Then
            Call SetSystemCursor(hIcon, arCurs(i))
            Call DestroyIcon(hIcon)
        End If
    Next

End Property


Private Function IsVBEActive() As Boolean
    IsVBEActive = CBool(GetActiveWindow = FindWindow("wndclass_desked_gsk", vbNullString))
End Function

Private Function ColorToRGB(ByVal Col As Long) As RGB
    ColorToRGB.R = &HFF& And Col
    ColorToRGB.G = (&HFF00& And Col) \ 256
    ColorToRGB.B = (&HFF0000 And Col) \ 65536
End Function

Private Sub Auto_Close()
    bExitLoop = True
End Sub




2- UserForm Code example stays the same as in Post#24
 
Upvote 1
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
You must log in or register to reply here.

Similar threads

T
  • Solved
Chart point must move to point of click in chart
Replies
2
Views
166
tigger_na
T
Jaafar Tribak
  • Question
Blurring images using Direct2D & Windows Imaging Component
Replies
3
Views
318
Dan_W
D
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
373
huiettcm
H
netspeedz
  • Solved
Load Image in User Form - 64bit Excel [VBA]
Replies
6
Views
513
netspeedz
netspeedz
E
  • Solved
Public Declare PrtSafe Function Not Defined
Replies
2
Views
415
Eldrod
E

Forum statistics

Threads
1,216,072
Messages
6,128,632
Members
449,460
Latest member
jgharbawi

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