GetPixel Pixel Color not translating to Excel 2013

TheSpriceEffect

New Member
Joined
Aug 29, 2014
Messages
1
I created a program that works in Excel 2007 and 2010, but there is one sub that I cannot get to work in 2013 which does the following:

When there is a picture on the sheet (top left at cell AA1)
Set the cursor position onto a specific pixel location
Get cursor position
Get pixel color at that position
Set the fill color of the cell behind that position to the pixel color
Loop

I am wondering if there are any functions that I used that work differently in Excel 2013 compared to 2010 and 2007 because when I run the sub, every cell is turned to white (when obviously the image I am using is not just white). It would be a huge help if someone could identify what is causing the problem! Here is the code for that sub:

Code:
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long
Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
Private Declare Function CreateICA Lib "gdi32" (ByVal sDriver As String, _
ByVal sDevice As String, ByVal sOut As String, ByVal pDVM As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, _
ByVal nIndex As Long) As Long

Public running As Boolean

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

Private Type POINT
    x As Long
    y As Long
End Type

Private Function GetWindowHandle() As Long

Const CLASSNAME_MSExcel = "XLMAIN"

GetWindowHandle = FindWindow(CLASSNAME_MSExcel, vbNullString)
End Function

Sub GenerateField()
Dim ColorInteger As Long
Dim CurrentCell As Range
Dim pic As Object
Dim Rows As Integer
Dim Columns As Integer
Dim cnt As Integer
Dim Rec As Rect, i
Dim pLocation As POINT
Dim hDC As Long
Dim xRes As Long
Dim yRes As Long
Dim xWidth As Single
Dim yHeight As Single
Dim xPoints As Double
Dim yPoints As Double
Dim ZoomFactorX As Integer
Dim ZoomFactorY As Integer

cnt = 0
For Each pic In ActiveSheet.Pictures
    cnt = cnt + 1
Next pic
    
If cnt = 0 Then
    MsgBox "Error: You must select an image first"

ElseIf cnt > 1 Then
    MsgBox "Error: There should only be one image"

ElseIf IsNumeric(UserForm1.TextBox1.Value) And IsNumeric(UserForm1.TextBox2.Value) And UserForm1.TextBox1.Value > 0 And UserForm1.TextBox2.Value > 0 Then
    Rows = UserForm1.TextBox1.Value
    Columns = UserForm1.TextBox2.Value
    
    Application.WindowState = xlMaximized
    Range("a1").Select
    GetWindowRect GetWindowHandle, Rec
    hDC = CreateICA("DISPLAY", vbNullString, vbNullString, 0)
    If (hDC <> 0) Then
        xRes = GetDeviceCaps(hDC, 88)
        yRes = GetDeviceCaps(hDC, 90)
        DeleteDC (hDC)
    End If
    xPoints = Sheets(2).Range("a1").Width
    yPoints = Sheets(2).Range("a1").Height
    xWidth = (xPoints / 72) * xRes
    yHeight = (yPoints / 72) * yRes
    
    For i = 0 To Rows - 1
        For j = 0 To Columns - 1
            Set CurrentCell = ActiveSheet.Cells(1, 27).Offset(i, j)
            
            ZoomFactorX = xWidth * ActiveWindow.Zoom / 100
            ZoomFactorY = yHeight * ActiveWindow.Zoom / 100
            x = (ActiveWindow.PointsToScreenPixelsX(Range("a1").Left)) + (26.5 + j) * ZoomFactorX
            y = (ActiveWindow.PointsToScreenPixelsY(Range("a1").Top)) + (i) * ZoomFactorY + 0.5 * yHeight
            
            'MsgBox x & ", " & y
            
            SetCursorPos x, y
            
            Call GetCursorPos(pLocation)
             
            hDC = GetDC(Application.hwnd)
            
            ColorInteger = GetPixel(hDC, pLocation.x, pLocation.y)
            
            CurrentCell.Interior.Color = ColorInteger
        DoEvents
        Next j
    Next i
    
    'For Each pic In ActiveSheet.Pictures
    'pic.Delete
    'Next pic
    
Else
    MsgBox "Error: Please use 'Resize Field' to select the size of your field"
End If
End Sub
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

Forum statistics

Threads
1,223,262
Messages
6,171,080
Members
452,377
Latest member
bradfordsam

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