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

[Dendro]

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:

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:

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

 

[NatAes]

Sorry but i am just trying to visualize how the user is actually getting the X and Y coordinates using the GetCursorPos API.
Is that inside a loop or a timer routine ?

I'm currently using an 'eyedropper' tool, which I've adapted from post #6 of this forum thread, so that the imgDropper_MouseUp sub outputs the Pnt.X and Pnt.Y values.

 

[Jaafar Tribak]

I can't download that workbook from the excelforum website as it needs registration.
Can you upload the workbook (tool) you are using to file sharing website and post a link to it here ?

 

[Jaafar Tribak]

In post#8 you mentioned :
"and trying to calculate the average colour for a user-defined area of the image"

Do you mean the sum of all the pixels divided the total pixels found in the area ? If you can confirm that, I'll post some code that i have almost finished writing .

Regards.

 

[Jaafar Tribak]

Ok - See if this works for you and achieves what you are after.

Workbook Example

Basically, the code uses a UserForm that works as an Image Picker tool ... Once you select with the mouse a portion of the screen, the code makes a bitmap in memory which you can then query for the number of pixels and the average color :

1- API code in a Standard Module:

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 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 tBm As BITMAP, tSize As Size
    Dim arPixels() As Long, oCol As Collection
    Dim lRow As Long, lCol As Long, lPix As Long
   
    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_
            ReDim Preserve arPixels(lPix)
            arPixels(lPix) = GetPixel(hMemDC, lRow, lCol)
            oCol.Add arPixels(lPix), CStr(arPixels(lPix))
            lPix = lPix + 1
            'DoEvents
        Next lCol
    Next lRow
   
     lTotalColors = oCol.Count
    CalculateAverageColor = Application.WorksheetFunction.Average(arPixels)

Err_:
     Call MakeNormal
     Call DeleteDC(hMemDC)

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 Sub Auto_Close()
    bExitLoop = True
End Sub

2- Code Usage Example ( UserForm )

Option Explicit


Private Sub UserForm_Initialize()

    FrmPreview.PictureSizeMode = fmPictureSizeModeClip
    OptClip.Value = True
    With CbMousePointer
        .AddItem "ARROW"
        .AddItem "CROSS"
        .AddItem "HAND"
        .Value = .List(1)
    End With
    Mouse_Pointer = IDC_CROSS

End Sub


Private Sub UserForm_Activate()

    lblAvrColor.BackColor = &H8000000F
    lblAvrValue.Caption = ""
    lblTotalValue.Caption = ""
    lblCalc.Visible = False
   
    Select Case True
        Case OptClip.Value = True
            FrmPreview.PictureSizeMode = fmPictureSizeModeClip
        Case OptStretch.Value = True
            FrmPreview.PictureSizeMode = fmPictureSizeModeStretch
        Case OptZoom.Value = True
            FrmPreview.PictureSizeMode = fmPictureSizeModeZoom
    End Select
   
    Select Case CbMousePointer.Value
        Case "ARROW"
            Mouse_Pointer = OCR_ARROW
        Case "CROSS"
            Mouse_Pointer = IDC_CROSS
        Case "HAND"
            Mouse_Pointer = IDC_HAND
    End Select

End Sub


Private Sub BtnAverage_Click()

    If Not Me.FrmPreview.Picture Is Nothing Then
        lblCalc.Visible = True
        lblCalc.Caption = "Calculating..."
        DoEvents
        Call MakeTopMost(True)
        lblAvrColor.BackColor = CalculateAverageColor
        Call MakeTopMost(False)
        lblAvrValue.Caption = Hex(lblAvrColor.BackColor)
        lblTotalValue.Caption = GetTotalColors
        lblCalc.Visible = False
    Else
        MsgBox "Select an Image", vbInformation
    End If

End Sub

Private Sub btnSelect_Click()

    Me.Hide
    Call SelectSectionOfTheScreen(Me, Me.FrmPreview)
   
End Sub

Private Sub CbMousePointer_Change()

    Select Case CbMousePointer.Value
        Case "ARROW"
            Mouse_Pointer = OCR_ARROW
        Case "CROSS"
            Mouse_Pointer = IDC_CROSS
        Case "HAND"
            Mouse_Pointer = IDC_HAND
    End Select

End Sub


Private Sub OptClip_Enter()
    FrmPreview.PictureSizeMode = fmPictureSizeModeClip
End Sub

Private Sub OptStretch_Enter()
    FrmPreview.PictureSizeMode = fmPictureSizeModeStretch
End Sub

Private Sub OptZoom_Enter()
    FrmPreview.PictureSizeMode = fmPictureSizeModeZoom
End Sub

Private Sub btnClose_Click()
    Unload Me
End Sub

 

[NatAes]

Ok - See if this works for you and achieves what you are after.

Workbook Example

Basically, the code uses a UserForm that works as an Image Picker tool ... Once you select with the mouse a portion of the screen, the code makes a bitmap in memory which you can then query for the number of pixels and the average color :

1- API code in a Standard Module:

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 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 tBm As BITMAP, tSize As Size
    Dim arPixels() As Long, oCol As Collection
    Dim lRow As Long, lCol As Long, lPix As Long
  
    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_
            ReDim Preserve arPixels(lPix)
            arPixels(lPix) = GetPixel(hMemDC, lRow, lCol)
            oCol.Add arPixels(lPix), CStr(arPixels(lPix))
            lPix = lPix + 1
            'DoEvents
        Next lCol
    Next lRow
  
     lTotalColors = oCol.Count
    CalculateAverageColor = Application.WorksheetFunction.Average(arPixels)

Err_:
     Call MakeNormal
     Call DeleteDC(hMemDC)

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 Sub Auto_Close()
    bExitLoop = True
End Sub

2- Code Usage Example ( UserForm )

Option Explicit


Private Sub UserForm_Initialize()

    FrmPreview.PictureSizeMode = fmPictureSizeModeClip
    OptClip.Value = True
    With CbMousePointer
        .AddItem "ARROW"
        .AddItem "CROSS"
        .AddItem "HAND"
        .Value = .List(1)
    End With
    Mouse_Pointer = IDC_CROSS

End Sub


Private Sub UserForm_Activate()

    lblAvrColor.BackColor = &H8000000F
    lblAvrValue.Caption = ""
    lblTotalValue.Caption = ""
    lblCalc.Visible = False
  
    Select Case True
        Case OptClip.Value = True
            FrmPreview.PictureSizeMode = fmPictureSizeModeClip
        Case OptStretch.Value = True
            FrmPreview.PictureSizeMode = fmPictureSizeModeStretch
        Case OptZoom.Value = True
            FrmPreview.PictureSizeMode = fmPictureSizeModeZoom
    End Select
  
    Select Case CbMousePointer.Value
        Case "ARROW"
            Mouse_Pointer = OCR_ARROW
        Case "CROSS"
            Mouse_Pointer = IDC_CROSS
        Case "HAND"
            Mouse_Pointer = IDC_HAND
    End Select

End Sub


Private Sub BtnAverage_Click()

    If Not Me.FrmPreview.Picture Is Nothing Then
        lblCalc.Visible = True
        lblCalc.Caption = "Calculating..."
        DoEvents
        Call MakeTopMost(True)
        lblAvrColor.BackColor = CalculateAverageColor
        Call MakeTopMost(False)
        lblAvrValue.Caption = Hex(lblAvrColor.BackColor)
        lblTotalValue.Caption = GetTotalColors
        lblCalc.Visible = False
    Else
        MsgBox "Select an Image", vbInformation
    End If

End Sub

Private Sub btnSelect_Click()

    Me.Hide
    Call SelectSectionOfTheScreen(Me, Me.FrmPreview)
  
End Sub

Private Sub CbMousePointer_Change()

    Select Case CbMousePointer.Value
        Case "ARROW"
            Mouse_Pointer = OCR_ARROW
        Case "CROSS"
            Mouse_Pointer = IDC_CROSS
        Case "HAND"
            Mouse_Pointer = IDC_HAND
    End Select

End Sub


Private Sub OptClip_Enter()
    FrmPreview.PictureSizeMode = fmPictureSizeModeClip
End Sub

Private Sub OptStretch_Enter()
    FrmPreview.PictureSizeMode = fmPictureSizeModeStretch
End Sub

Private Sub OptZoom_Enter()
    FrmPreview.PictureSizeMode = fmPictureSizeModeZoom
End Sub

Private Sub btnClose_Click()
    Unload Me
End Sub

Wow! This is unbelievable - thank you so much @Jaafar Tribak.

Sorry I never got round to replying to your earlier posts before you uploaded this, but I meant something slightly different by 'average colour'. Let's say a selection was half black and half white, the average colour would be grey. If it was 3/4 black and 1/4 white, then it would be a darker shade of grey. Just like mixing paints, although in this case pixel colours instead. The simplest way to do this is, I believe, to sum all the R values of the pixels in the selection and then divide by the number of pixels, and then the same for all G and B values respectively. That outputs the average RGB colour.

The code you uploaded calculates something else by average colour, as I just tried a selection of red and white and got a greyish average colour - when it should be a pinkish one.

 

[Jaafar Tribak]

Yes I see what you mean ... That's why I asked .
I'll come back to the code later on and edit it .

 

[Jaafar Tribak]

Ok - Here is the amended code for mixing paints :

Workbook Example

1- API code in a Standard Module:

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

 

[NatAes]

Ok - Here is the amended code for mixing paints :

Workbook Example

1- API code in a Standard Module:

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

This is excellent @Jaafar Tribak - it works beautifully and perfectly (given my testing so far)...you're a life saver! Thank you so much for your help.

 

[Jaafar Tribak]

This is excellent @Jaafar Tribak - it works beautifully and perfectly (given my testing so far)...you're a life saver! Thank you so much for your help.

I am glad the code worked as intended and thanks for the feedback.

Just out of interest, can you tell me about the bitness of the excel application where you used the code ? Is it 32bit or 64bit ?

Thanks.

 

[NatAes]

I'm using Excel 2013 64-bit.