VBA如何处理图像相似度问题求助

大氵寿 · 发表于 2023-7-10 17:54

本帖最后由大氵寿于 2023-7-10 18:07 编辑

在坛子里找了匹配图片的代码, 但是是直接根据每个像素rgb值去比对,

实际情况里每次像素点渲染可能有极度细微的差异, 导致匹配失败.

有没有什么算法, 能得出2个图片的整体相似度, 比如超过90%就认为找到了这个图.

Option Explicit
Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
'====================================================
Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare PtrSafe Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
'====================================================
Private Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
'左键单击
'====================================================
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long '获取句柄
Private Declare PtrSafe 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 PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long '释放DC
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Type POINTAPI '定义点(Point)结构
x As Long '点在X坐标(横坐标)上的坐标值
y As Long '点在Y坐标(纵坐标)上的坐标值
End Type
Public intX As Long
Public intY As Long
'颜色表
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbAlpha As Byte '透明通道
End Type
Private Type bitmap
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type BITMAPINFOHEADER
biSize As Long '位图大小
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer '信息头长度
biCompression As Long '压缩方式
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
'图片文件头
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
Dim BI As BITMAPINFO
Dim BI1 As BITMAPINFO
Private Const HIMETRIC_PER_PIXEL = 96 / 2540
Private Const vbPicTypeBitmap = 1
Private Enum EnumPicMode
BlackWhite = 0
GrayScale = 1
End Enum
Public Function FindPic(Left As Long, Top As Long, Right As Long, Bottom As Long, fileurl As String) As Boolean
Dim PicSrc As StdPicture
Dim ix As Integer
Dim iy As Integer
Dim iWidth As Integer '以像素为单位的图形宽度
Dim iHeight As Integer '以像素为单位的图形高度
Dim bytTarget As Byte
Dim hdc As Long, hDCmem As Long
Dim hBmp As Long, hBmpPrev As Long
Dim bits2()
Dim bits() As Byte '三维数组，用于获取原彩色图像中各像素的RGB数值以及存放转化后的灰度值
Dim bitsBW() As Byte '三维数组，用于存放转化为黑白图后各像素的值
Dim lrtn, w, h, paths
paths = ThisWorkbook.Path & "\pics" & fileurl
UserForm1.Image1.Picture = LoadPicture(paths)
Set PicSrc = UserForm1.Image1.Picture
'获取图形的宽度和高度
iWidth = PicSrc.Width * HIMETRIC_PER_PIXEL
iHeight = PicSrc.Height * HIMETRIC_PER_PIXEL
'创建并初始化一个bitMapInfo自定义类型
Dim bi24BitInfo As BITMAPINFO
With bi24BitInfo.bmiHeader
.biBitCount = 32
.biCompression = 0&
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = iWidth
.biHeight = iHeight
End With
'重新定义数组大小
ReDim bits(0 To 3, 0 To iWidth - 1, 0 To iHeight - 1) As Byte
hdc = GetDC(0)
hDCmem = CreateCompatibleDC(hdc)
'使用GetDIBits方法一次性获取picture1中各点的rgb值，比point方法或getPixel函数逐像素获取像素rgb要快出一个数量级
lrtn = GetDIBits(hDCmem, PicSrc.Handle, 0&, iHeight, bits(0, 0, 0), bi24BitInfo, DIB_RGB_COLORS)
'数组的三个维度分别代表像素的RGB分量、以图形左下角为原点的X和Y坐标。
'具体说来，这时bits(0,2,3)代表从图形左下角数起横向第2个纵向第3个像素的Blue值，而bits(1,2,3)和bits(2,2,3)分别的Green值和Red值.
ReleaseDC 0, hdc
w = Right
h = Bottom
With BI1.bmiHeader
.biSize = Len(BI1.bmiHeader)
.biWidth = w
.biHeight = h
.biBitCount = 32
.biPlanes = 1
End With
Dim hBMPhDC
Dim hDCmem2 As Long
Dim Pic1Handle2 As Long
Dim hBmpPrev2 As Long
Dim ixx, j, i, i2, j2
Dim fpic() As Byte
hBMPhDC = GetDC(0)
'常规抓图代码，得到一个hBmp：
hDCmem2 = CreateCompatibleDC(hBMPhDC)
Pic1Handle2 = CreateCompatibleBitmap(hBMPhDC, Right, Bottom)
hBmpPrev = SelectObject(hDCmem2, Pic1Handle2)
BitBlt hDCmem2, 0, 0, Right, Bottom, hBMPhDC, Left, Top, SRCCOPY 'SelectObject hDCmem, hBmpPrev
ReDim fpic(0 To 3, 0 To w - 1, 0 To h - 1) As Byte
ixx = GetDIBits(hDCmem2, Pic1Handle2, 0&, h, fpic(0, 0, 0), BI1, 0)
ReleaseDC 0, hBMPhDC
FindPic = False
For j = 0 To h - iHeight - 1
VBA.DoEvents
For i = 0 To w - iWidth - 1
For j2 = 0 To iHeight - 1 '循环判断小图片
For i2 = 0 To iWidth - 1

复制代码

代码被截断了, 接着:

If fpic(2, i + i2, j + j2) < 0.9 * bits(2, i2, j2) Or fpic(2, i + i2, j + j2) > 1.1 * bits(2, i2, j2) Then GoTo ExitLine: 'R
If fpic(1, i + i2, j + j2) < 0.9 * bits(1, i2, j2) Or fpic(1, i + i2, j + j2) > 1.1 * bits(1, i2, j2) Then GoTo ExitLine: 'G
If fpic(0, i + i2, j + j2) < 0.9 * bits(0, i2, j2) Or fpic(0, i + i2, j + j2) > 1.1 * bits(0, i2, j2) Then GoTo ExitLine: 'B
Next i2
Next j2
'Debug.Print "发现:", I, J
intX = i
intY = h - j - iHeight
FindPic = True
'MoveTo intX, intY
'MsgBox intX & "" & intY
ExitLine:
Next i
Next j
End Function

复制代码

perfect131 · 发表于 2023-7-10 19:12

比较两张图？你可以用 wia 获取 argb来比较
ARGBData

约定的童话 · 发表于 2023-7-11 21:08

在VBA中处理图像相似度问题，可以借助于图像处理库如OpenCV或EmguCV来实现。以下是一个示例代码，使用EmguCV计算两个图像的相似度。

首先，需要将EmguCV库添加到VBA项目的引用中。可以在工具->引用中选择"Emgu.CV"。

然后，可以使用以下代码来计算两个图像的相似度：

```vba
Sub CalculateImageSimilarity()
' 图片路径
Dim imagePath1 As String
Dim imagePath2 As String
imagePath1 = "path to image 1"
imagePath2 = "path to image 2"

' 创建图像对象
Dim img1 As New Emgu.CV.Image(Of Emgu.CV.Structure.Bgr, Byte)(imagePath1)
Dim img2 As New Emgu.CV.Image(Of Emgu.CV.Structure.Bgr, Byte)(imagePath2)

' 声明变量保存相似度
Dim similarity As Double

' 创建图像比较器
Dim imageComparer As New Emgu.CV.ImageSimilarity(img1, img2)

' 计算相似度
similarity = imageComparer.GetSimilarity()

' 输出相似度
MsgBox "相似度: " & similarity
End Sub
```

在上述代码中，替换`imagePath1`和`imagePath2`为你要比较的两个图像的路径。然后通过`Emgu.CV.Image`类创建图像对象。接着，创建`Emgu.CV.ImageSimilarity`对象，传入图像对象。最后，调用`GetSimilarity`方法，返回相似度值。

请注意，这只是一个简单示例，在实际应用中可能需要进行更复杂的图像处理和相似度计算。

		自动登录	找回密码
密码			免费注册

[求助] VBA如何处理图像相似度问题求助