在 VBA 中逐像素扫描图像 [英] Scan image pixel by pixel in VBA

问题描述

这里有一个近乎准确的问题读取图像的像素颜色

There is a near exact question here Read pixel colors of an image

Op 实际上提出了与我要求相同的问题.但是接受一个几乎存在但不完全的答案.. 下面的代码(取自该线程)完成了我需要的所有操作，逐个像素地显示.如果您单击图像，它将在单击站点上为您提供颜色.当我想扫描整个图片时，我虽然我只是做一个 X Y 扫描并将顺序的 X 和 Y 放入而不是 GetCursorPos 调用返回的 X 和 Y.但是如何以像素为单位获得左侧位置和宽度(例如)以开始扫描?我会在 for next 循环中放入什么来处理每个像素?

The Op actually asks the same question as I'm asking for. But accepts an answer that is nearly there but not quite.. The code below (taken from that thread) does everything I need bar the pixel by pixel bit. If you click on an image it will give you the colour at the click site. As I want to scan the whole picture I though I'd just do an X Y scan and put the sequential X and Y's in instead of the returned X and Y of the GetCursorPos call. But how to get left position and width (for example) in pixels to start the scan? What would I put in my for next loop to address each pixel ?

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

So to clarify my question. How to change the code below to scan every pixel of the image not just the clicked cursor position. Thanks

#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

这篇关于在 VBA 中逐像素扫描图像的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！