这里有一个近乎精确的问题读取图像的像素颜色 https://stackoverflow.com/questions/16528319/read-pixel-colors-of-an-image
实际上,Op 提出的问题与我所问的问题相同。但接受一个几乎就在那里但不完全是的答案。下面的代码(取自该线程)完成了我需要的一切,除了逐个像素位。如果您单击图像,它将为您提供单击站点的颜色。因为我想扫描整个图片,所以我只想进行 X Y 扫描并放入连续的 X 和 Y,而不是 GetCursorPos 调用返回的 X 和 Y。但是如何获取左侧位置和宽度(例如)以像素为单位来开始扫描?我会在 for next 循环中放入什么来处理每个像素?
所以为了澄清我的问题。
如何更改下面的代码以扫描图像的每个像素而不仅仅是单击的光标位置。谢谢
#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
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
本文内容由网友自发贡献,版权归原作者所有,本站不承担相应法律责任。如您发现有涉嫌抄袭侵权的内容,请联系:hwhale#tublm.com(使用前将#替换为@)