Question

这里有一个近似确切的问题 Read pixel colors of an image

Op实际上提出的问题与我要求的相同。但接受一个几乎存在但不完全的答案..下面的代码（取自该线程）做我需要的所有内容逐像素位。如果单击图像，它将为您提供点击网站的颜色。因为我想要扫描整个图片，但我只是进行X Y扫描并将顺序X和Y放入，而不是GetCursorPos调用返回的X和Y.但是如何以像素为单位获得左侧位置和宽度（例如）以开始扫描？我将在下一个循环中添加什么来处理每个像素？

所以澄清我的问题。如何更改下面的代码来扫描图像的每个像素而不仅仅是单击的光标位置。谢谢

#If VBA7 Then
    Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As LongPtr
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
#Else
    Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long,     ByVal y As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
    Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
#End If
Private Type POINT
    x As Long
    y As Long
End Type

Sub Picture1_Click()
    Dim pLocation As POINT
    Dim lColour As Long

    Dim lDC As Variant
    lDC = GetWindowDC(0)
    Call GetCursorPos(pLocation)
    lColour = GetPixel(lDC, pLocation.x, pLocation.y)
    Range("a1").Interior.Color = lColour
End Sub

Answer 1

Option Explicit

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 GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long


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

Private Type POINTAPI
    X As Long
    Y As Long
End Type
Dim IDC As Long

Private Function ScreenDPI(bVert As Boolean) As Long
  '*** Get screen DPI ***
  Static lDPI&(1), lDC&
  If lDPI(0) = 0 Then
    lDC = GetDC(0)
    lDPI(0) = GetDeviceCaps(lDC, 88&)    'horz
    lDPI(1) = GetDeviceCaps(lDC, 90&)    'vert
    lDC = ReleaseDC(0, lDC)
  End If
  ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
'*** Swap Points to pixels ****
  PTtoPX = Points * ScreenDPI(bVert) / 72
End Function
Sub GetImageRect(ByRef RC As RECT)
Dim RNG As Range
Set RNG = Sheet1.Range("A1")

'**** using the spread sheet cell A1 as a reference ***
'** find the details of th eimage and convert to pixels ***
  Dim wnd As Window
  Set wnd = RNG.Parent.Parent.Windows(1)
  With Sheet1.Image1
    RC.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) + wnd.PointsToScreenPixelsX(0)
    RC.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) + wnd.PointsToScreenPixelsY(0)
    RC.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) + RC.Left
    RC.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) + RC.Top
  End With
End Sub

Sub XYScanOfImage()
'*** put an active X image on sheet1 call it image1 and run this routine **
'** to get the colour information for each pixel *****
Dim RC As RECT
Dim ScanX As Single
Dim ScanY As Single
Dim ImX As Single
Dim ImY As Single
Dim PixCol As Single

Call GetImageRect(RC)
ImX = RC.Left
ImY = RC.Top

IDC = GetDC(0)
'*** scan image left to right top to bottom ****
For ScanX = RC.Left To RC.Right
  For ScanY = RC.Top To RC.Bottom
    PixCol = GetPixel(IDC, ScanX, ScanY)
    '**** PUT CODE IN HERE TO PROCESS THE PIXEL COLOUR ****
  Next
Next
IDC = ReleaseDC(0, IDC)
End Sub

Answer 2

perfo 的答案非常棒-可行！

一些注意事项：

您必须将图像添加为ActiveX控件（要执行此操作，请转到Excel Developer功能区，然后在图像上单击鼠标右键并将其名称设置为Image1-无论如何这都是默认值）。
此外，请确保它在VBA中称为Sheet1的工作表上（同样，这应该是默认设置）。

该例程返回RGBA颜色。我创建了以下例程为每个单元着色：

Sub ColourCell(c As Range, ThisColour As Single)

'colour the passed in range

Dim Red As Byte
Dim Green As Byte
Dim Blue As Byte

Red = ThisColour And &HFF&
Green = (ThisColour And &HFF00&) / 256
Blue = (ThisColour And &HFF0000) / 65535

c.Interior.Color = RGB(Red, Green, Blue)

End Sub

我修改了答案，以使活动单元格中的单元格向下和向下着色，如下所示：

'*** scan image left to right top to bottom ****
Dim i As Integer
Dim j As Integer

Dim OriginalRowNumber As Integer
Dim OriginalColumnNumber As Integer

OriginalRowNumber = ActiveCell.Row
OriginalColumnNumber = ActiveCell.Column

i = OriginalRowNumber
j = OriginalColumnNumber

Sheet1.Select

Cells.EntireColumn.ColumnWidth = 0.63
Cells.EntireRow.RowHeight = 6

For ScanX = RC.Left To RC.Right
  For ScanY = RC.Top To RC.Bottom
    PixCol = GetPixel(IDC, ScanX, ScanY)
    ColourCell Cells(j, i), PixCol
    j = j + 1
    
  Next
  i = i + 1
  
  If i Mod 5 = 0 Then Stop
  
  j = OriginalColumnNumber
  
Next

其中有几个额外的位来设置微小的网格大小，因此您可以看到图片展开，并且有一条调试行每五列暂停一次宏（运行时间很长）。

在VBA中逐像素扫描图像

2 个答案: