|
-
Mar 16th, 2024, 07:26 PM
#1
Thread Starter
Fanatic Member
Image Processing: Image similarity algorithms aHash, dHash, pHash
There are about 4 types of hashing algorithms:
Difference Hash: DHash(Difference Hash)
Average Hash: AHash(Average Hash)
Perceptual Hash: PHash (Perceptual Hash)
Wavelet Hash: WHash (Wavelet Hash) I won't convert this, I'm so bad at math
If there are errors, fix them ?thanks
There are a lot of pearls in the forum, and we need to connect them together, thanks to every master of open source
Code:
Option Explicit
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
Private Declare 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 Function GetClientRect _
Lib "user32" (ByVal hWnd As Long, _
lpRect As RECT) As Long '??????????????" ()
Private Declare Function GetWindowRect _
Lib "user32" (ByVal hWnd As Long, _
ByRef lpRect As RECT) As Long '??????????????
Private Declare Function SetForegroundWindow _
Lib "user32" (ByVal hWnd As Long) As Long '?????
Private Declare Function IsWindowVisible _
Lib "user32" (ByVal hWnd As Long) As Long '?????????????TRUE????
Private Declare Function FlashWindow _
Lib "user32" (ByVal hWnd As Long, _
ByVal bInvert As Long) As Long '???????
'????
'Private Type POINTAPI: X As Long: Y As Long: End Type '???????
Private Declare Function GetCursorPos _
Lib "user32" (lpPoint As POINTAPI) As Long '???????????????
Private Declare Function SetCursorPos _
Lib "user32" (ByVal x As Long, _
ByVal y As Long) As Long '??????????????????
'?????????????????????????
'????
Private Declare Function ClientToScreen _
Lib "user32" (ByVal hWnd As Long, _
lpPoint As POINTAPI) As Long '??????????
Private Declare Function ScreenToClient _
Lib "user32" (ByVal hWnd As Long, _
lpPoint As POINTAPI) As Long '??????????
Private Declare Function MapWindowPoints _
Lib "user32" (ByVal hwndFrom As Long, _
ByVal hwndTo As Long, _
lpPoint As POINTAPI, _
ByVal cPoints As Long) As Long '2????????’??lpPoint As POINTAPI?? lppt As RECT????cPoints=2
'?????????????????????????
'/////////////////////
'??
Private Declare Function timeGetTime Lib "winmm.dll" () As Long '??timeGetTime???????????
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) '????????
'????
'Private Declare PtrSafe Function MsgBoxEx Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As VbMsgBoxStyle, ByVal wlange As Long, ByVal dwTimeout As Long) As Long '??MsgBoxEx
Private Declare Function GetForegroundWindow Lib "user32" () As Long '???????????
Private Declare Function MsgBoxEx _
Lib "user32" _
Alias "MessageBoxTimeoutA" (ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As VbMsgBoxStyle, _
ByVal wlange As Long, _
ByVal dwTimeout As Long) As Long '??MsgBoxEx
'hwnd??????????0, lpText????????????MsgBox????????Prompt,lpCaption??????????MsgBox????????Caption
' wType??????????MsgBox????????Buttons, wlange???????????0??1????????, dwTimeout???????????
'?????????????????????????
#If Win64 Then
Private Declare PtrSafe Sub SetThreadExecutionState Lib "kernel32" (ByVal esFlags As Long) '????
#Else
Private Declare Sub SetThreadExecutionState _
Lib "kernel32" (ByVal esFlags As Long) '????
#End If
Private Enum Execution_State '????
ES_SYSTEM_REQUIRED = &H1
ES_DISPLAY_REQUIRED = &H2
ES_AWAYMODE_REQUIRED = &H4
ES_CONTINUOUS = &H80000000
End Enum
'???????????>>>>>>
'SetThreadExecutionState Execution_State.ES_SYSTEM_REQUIRED Or _
Execution_State.ES_DISPLAY_REQUIRED Or _
Execution_State.ES_CONTINUOUS '????
'SetThreadExecutionState Execution_State.ES_CONTINUOUS '????
'////////////////////////////////////////////////
'
'============
'ColorProcess
'============
'
'A global predeclared object providing the method:
'
' o ReplaceColor( _
' ByVal Original As StdPicture, _
' ByVal FromColor As Long, _
' ByVal ToColor As Long) As StdPicture
'
' The two colors are in COLORREF format, i.e. what VB6 calls an RGB color.
'
'Notes:
'
' o Not tested on a system with a display color depth < 24-bit color.
'
'=
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
HBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function CreateCompatibleBitmap _
Lib "gdi32" (ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare Function GetDeviceCaps _
Lib "gdi32" (ByVal hdc As Long, _
ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries _
Lib "gdi32" (ByVal hdc As Long, _
ByVal wStartIndex As Long, _
ByVal wNumEntries As Long, _
lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectObject _
Lib "gdi32" (ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function StretchBlt _
Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, _
ByVal nSrcHeight As Long, _
ByVal dwRop As Long) As Long
'Private Declare Function BitBlt _
Lib "gdi32" (ByVal hDCDest As Long, _
ByVal XDest As Long, _
ByVal YDest As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hDCSrc As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Declare Function SelectPalette _
Lib "gdi32" (ByVal hdc As Long, _
ByVal hPalette As Long, _
ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
' BitBlt ????
Private Const SRCCOPY = &HCC0020
Private Const SRCINVERT = &H660046
' PatBlt ????
Private Const DINV = 3
Private Const DSTINVERT = &H550009
Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
Private Declare Function OleCreatePictureIndirect2 _
Lib "olepro32.dll" _
Alias "OleCreatePictureIndirect" (PicDesc As PicBmp, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
iPic As IPicture) As Long
'=============================
Private Const WIN32_FALSE As Long = 0
Private Const WIN32_TRUE As Long = 1
Private Const WIN32_NULL As Long = 0
Private Const S_OK As Long = 0
Private Const DIB_RGB_COLORS As Long = 0
Private Enum BiCompressionValues
BI_RGB = 0 'We're only using this value here.
End Enum
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As BiCompressionValues
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO_NOPALETTE
bmiHeader As BITMAPINFOHEADER
End Type
Private Type PICTDESC_BMP
Size As Long
Type As Long
HBmp As Long
hPal As Long
Reserved As Long
End Type
Private Type IID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Declare Function CLSIDFromString _
Lib "ole32" (ByVal lpsz As Long, _
ByRef clsid As IID) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection _
Lib "gdi32" (ByVal hdc As Long, _
ByRef BMI As Any, _
ByVal iUsage As Long, _
ByRef pvBits As Long, _
Optional ByVal hSection As Long = WIN32_NULL, _
Optional ByVal dwOffset As Long = 0) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDIBits _
Lib "gdi32" (ByVal hdc As Long, _
ByVal hBitmap As Long, _
ByVal nStartScan As Long, _
ByVal nNumScans As Long, _
ByRef Bits As Any, _
ByRef BMI As Any, _
ByVal wUsage As Long) As Long
Private Declare Sub MoveMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" (ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long)
Private Declare Function OleCreatePictureIndirect _
Lib "oleaut32" (ByRef PICTDESC As Any, _
ByRef RefIID As IID, _
ByVal fPictureOwnsHandle As Long, _
ByRef iPic As IPicture) As Long
Private Declare Function ReleaseDC _
Lib "user32" (ByVal hWnd As Long, _
ByVal hdc As Long) As Long
Private hMemDC As Long
Private IID_IPicture As IID
Private Enum InterpolationMode
InterpolationModeDefault = &H0
InterpolationModeLowQuality = &H1
InterpolationModeHighQuality = &H2
InterpolationModeBilinear = &H3
InterpolationModeBicubic = &H4
InterpolationModeNearestNeighbor = &H5
InterpolationModeHighQualityBilinear = &H6
InterpolationModeHighQualityBicubic = &H7
End Enum
Private Enum PictureTypeConstants
vbPicTypeNone = 0
vbPicTypeBitmap = 1
vbPicTypeMetafile = 2
vbPicTypeIcon = 3
vbPicTypeEMetafile = 4
End Enum
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
'Private Type GUID
' Data1 As Long
' Data2 As Integer
' Data3 As Integer
' Data4(0 To 7) As Byte
'End Type
'Private Type RECT
' Left As Long
' Top As Long
' Right As Long
' Bottom As Long
'End Type
'Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
'Private Declare Function GetClientRect _
Lib "user32" (ByVal hwnd As Long, _
lpRect As RECT) As Long
'Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
'Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
'Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As Any, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
'Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function OleCreatePictureIndirectAut _
Lib "oleAut32.dll" _
Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
iPic As IPicture) As Long
'Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
'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 GdiplusStartup _
Lib "gdiplus" (Token As Long, _
inputbuf As GdiplusStartupInput, _
Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipDeleteGraphics _
Lib "GdiPlus.dll" (ByVal mGraphics As Long) As Long
Private Declare Function GdipCreateFromHDC _
Lib "gdiplus" (ByVal hdc As Long, _
hGraphics As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP _
Lib "GdiPlus.dll" (ByVal hbm As Long, _
ByVal hPal As Long, _
ByRef pbitmap As Long) As Long
Private Declare Function GdipSetInterpolationMode _
Lib "GdiPlus.dll" (ByVal hGraphics As Long, _
ByVal Interpolation As Long) As Long
Private Declare Function GdipDrawImageRectRect _
Lib "GdiPlus.dll" (ByVal hGraphics As Long, _
ByVal hImage As Long, _
ByVal dstX As Single, _
ByVal dstY As Single, _
ByVal dstWidth As Single, _
ByVal dstHeight As Single, _
ByVal srcX As Single, _
ByVal srcY As Single, _
ByVal srcWidth As Single, _
ByVal srcHeight As Single, _
ByVal srcUnit As Long, _
ByVal imageAttributes As Long, _
ByVal Callback As Long, _
ByVal callbackData As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
'Private Declare Function StretchBlt ' Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ' ByVal nSrcHeight As Long, ' ByVal dwRop As Long) As Long
Private Declare Function SetStretchBltMode _
Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal nStretchMode As Long) As Long
Private Const STRETCH_HALFTONE As Long = 4
'Private Declare 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 Const SRCCOPY = &HCC0020
'Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
'Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
'Private Declare Function GetWindowDC Lib "user32.dll" (ByVal hWnd As Long) As Long
'Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
'Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SetBkMode _
Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
Private Const TRANSPARENT As Long = 1
' Variable to hold 'HBmp' property value
Private m_LonHBmp As Long
'????????????????????stdpicture ??????????
Public Property Get HBmp() As Long
HBmp = m_LonHBmp
End Property
'?????
Public Sub DeleteObjectHBmp()
DeleteObject m_LonHBmp
End Sub
Private Function ScaleStdPicture(thePicturehandle As Long, _
thePictureWidth As Long, _
thePictureheight As Long, _
NewWidth As Single, _
NewHeight As Single) As StdPicture
' Pass dimensions in Pixels only
Dim GDIsi As GdiplusStartupInput, gToken As Long
Dim BIH(0 To 9) As Long ' FAUX BitmapInfoHeader structure
Dim hGraphics As Long, hBitmap As Long
Dim tDC As Long, tHandle As Long
Dim hdc As Long
Dim cX As Single, cY As Single
Dim lDPI As Long
GDIsi.GdiplusVersion = 1&
GdiplusStartup gToken, GDIsi ' initialize GDI+
If gToken = 0 Then Exit Function
BIH(0) = 40
BIH(1) = NewWidth: BIH(2) = NewHeight
BIH(3) = &H180001 ' planes & 24 bit
hdc = GetDC(0)
tDC = CreateCompatibleDC(hdc) ' create buffer
ReleaseDC 0, hdc
tHandle = SelectObject(tDC, CreateDIBSection(tDC, BIH(0), 0&, ByVal 0&, 0&, 0&))
If tHandle = 0 Then
GdiplusShutdown gToken ' failed to create DIB section
DeleteDC tDC ' clean up
Exit Function
Else
Call GdipCreateFromHDC(tDC, hGraphics) ' get graphics context
If hGraphics Then ' set stretch quality & copy stdPicture bitmap/jpg
GdipSetInterpolationMode hGraphics, InterpolationModeHighQualityBicubic
Call GdipCreateBitmapFromHBITMAP(thePicturehandle, 0&, hBitmap)
If hBitmap Then ' render to the buffer
lDPI = pvGetDPI()
cX = thePictureWidth '* lDPI / 2540!
cY = thePictureheight '* lDPI / 2540!
GdipDrawImageRectRect hGraphics, hBitmap, 0, 0, NewWidth, NewHeight, 0, 0, cX, cY, 2, 0, 0, 0
GdipDisposeImage hBitmap ' clean up
End If
GdipDeleteGraphics hGraphics ' clean up
End If
End If
GdiplusShutdown gToken ' clean up
tHandle = SelectObject(tDC, tHandle) ' remove our DIB section
DeleteDC tDC
' clean up & create stdPicture from DIB section
Set ScaleStdPicture = pvHandleToStdPicture(tHandle, vbPicTypeBitmap)
End Function
Private Function pvHandleToStdPicture(ByVal hImage As Long, _
ByVal imgType As PictureTypeConstants) As IPicture
Dim IID_IDispatch As GUID, uPicinfo As uPicDesc
Dim R As Long
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With uPicinfo
.Size = Len(uPicinfo)
.Type = PictureTypeConstants.vbPicTypeBitmap
.hPic = hImage
.hPal = 0
End With
R = OleCreatePictureIndirectAut(uPicinfo, IID_IDispatch, True, pvHandleToStdPicture)
If R <> 0 Then
DeleteObject hImage
Err.Raise R, TypeName(Me), "OleCreatePictureIndirect() error 0x" & Hex$(R)
End If
End Function
-
Mar 16th, 2024, 07:26 PM
#2
Thread Starter
Fanatic Member
Re: Image Processing: Image similarity algorithms aHash, dHash, pHash
Code:
Public Function GetaHash(picPathOrPictureBox As Variant, _
Optional returnPic As StdPicture) As String
Dim BMI As BITMAPINFO_NOPALETTE
Dim biWidth As Long
Dim biHeight As Long
Dim PixelValues() As Long
Dim i As Long
Dim hBitmapNew As Long
Dim pvBitsNew As Long
Dim PICTDESC As PICTDESC_BMP
Dim HRESULT As Long
'FromColor = COLORREFtoBGRx(FromColor)
'ToColor = COLORREFtoBGRx(ToColor)
Dim tmpPic As StdPicture
Dim tmpPicHandle As Long
Select Case TypeName(picPathOrPictureBox)
Case "String"
If Len(Dir(picPathOrPictureBox)) <> 0 Then
Set tmpPic = LoadPicture(picPathOrPictureBox)
tmpPicHandle = tmpPic.Handle
End If
Case "PictureBox"
Set tmpPic = picPathOrPictureBox.Picture
tmpPicHandle = tmpPic.Handle
Case "Long"
If picPathOrPictureBox <> 0 Then
tmpPicHandle = picPathOrPictureBox
End If
End Select
With BMI.bmiHeader
'Retrieve Original.Handle's metrics:
.biSize = LenB(BMI.bmiHeader)
' .biBitCount = 0 'Don't fetch color table or pixels.
'
If GetDIBits(hMemDC, tmpPicHandle, 0, 0, WIN32_NULL, BMI, DIB_RGB_COLORS) = 0 Then
Err.Raise &H80048000 Or (Err.LastDllError And &H7FFF&), TypeName(Me), "GetDIBits() error " & CStr(Err.LastDllError)
End If
biWidth = .biWidth '
biHeight = .biHeight '
End With
'?????8x8??
' pic.ScaleMode = vbTwips
' pic.AutoRedraw = True
' pic.Cls
' pic.Height = pic.ScaleY(8, vbPixels, pic.ScaleMode) + (pic.Height - pic.ScaleHeight)
'
' pic.Width = pic.ScaleX(8, vbPixels, pic.ScaleMode) + (pic.Width - pic.ScaleWidth)
'
' pic.PaintPicture tmpPic, 0, 0, pic.ScaleWidth, pic.ScaleHeight
'??????dc??8*8,??8,??8
Dim DeskHwnd As Long, hDCWnd As Long, hdcMem As Long, HBmp As Long, hBmpOld As Long, sMode As Long
DeskHwnd = 0 ' GetDesktopWindow()
hDCWnd = GetDC(DeskHwnd) ' GetWindowDC(DeskHwnd) '??DC
hdcMem = CreateCompatibleDC(hDCWnd) '??dc????
HBmp = CreateCompatibleBitmap(hDCWnd, 8, 8) '??DC????
Call ReleaseDC(DeskHwnd, hDCWnd) '??dc
hBmpOld = SelectObject(hdcMem, HBmp) '???????
Call SetBkMode(hdcMem, TRANSPARENT) '????????
Call SelectObject(hMemDC, tmpPicHandle)
sMode = SetStretchBltMode(hdcMem, STRETCH_HALFTONE) ' makes stretching better quality
Call StretchBlt(hdcMem, 0, 0, 8, 8, hMemDC, 0, 0, biWidth, biHeight, SRCCOPY)
SetStretchBltMode hdcMem, sMode ' reset stretchmode
HBmp = SelectObject(hdcMem, hBmpOld)
'pic.Refresh
'??????
With BMI.bmiHeader
'Retrieve Original.Handle's metrics:
.biSize = LenB(BMI.bmiHeader)
.biBitCount = 0 'Don't fetch color table or pixels.
'
If GetDIBits(hMemDC, HBmp, 0, 0, WIN32_NULL, BMI, DIB_RGB_COLORS) = 0 Then
Err.Raise &H80048000 Or (Err.LastDllError And &H7FFF&), TypeName(Me), "GetDIBits() error " & CStr(Err.LastDllError)
End If
biWidth = .biWidth '???8
biHeight = .biHeight '???8
'Retrieve Original.Handle's pixel data as 32-bit RGB values:
.biBitCount = 32
.biCompression = 0 'BI_RGB
'No padding required since we are using 32-bit (DWORD) pixels:
' tmpHandle = CreateCompatibleBitmap(hBMPhDC, biWidth, biHeight) '??????
' hBmpPrev = SelectObject(hBMPhDC, tmpHandle)
ReDim PixelValues(biWidth * biHeight - 1) '????
If GetDIBits(hMemDC, HBmp, 0, biHeight, PixelValues(0), BMI, DIB_RGB_COLORS) = 0 Then
Err.Raise &H80048000 Or (Err.LastDllError And &H7FFF&), TypeName(Me), "GetDIBits() error " & CStr(Err.LastDllError)
End If
End With
Call DeleteObject(HBmp)
Call DeleteDC(hdcMem)
'????
Dim A As RGBQUAD, Gray As Long, totleGray As Long, avgGray As Long
For i = 0 To UBound(PixelValues)
A = COLORREFtoRGBQUAD(PixelValues(i))
Dim GrayColor As Long
'Debug.Print "??" & a.rgbRed * 0.3; a.rgbGreen * 0.59; a.rgbBlue * 0.11
Gray = A.rgbRed * 0.3 + A.rgbGreen * 0.59 + A.rgbBlue * 0.11
GrayColor = RGB(A.rgbRed * 0.3, A.rgbGreen * 0.59, A.rgbBlue * 0.11)
totleGray = totleGray + Gray
PixelValues(i) = COLORREFtoBGRx(Gray)
Next
avgGray = totleGray / UBound(PixelValues) + 1 '??64?
Debug.Print "?????:" & avgGray
'????,??????????1,?????0
For i = 0 To UBound(PixelValues)
If COLORREFtoBGRx(PixelValues(i)) > avgGray Then
PixelValues(i) = COLORREFtoBGRx(vbBlack)
GetaHash = GetaHash & "1"
Else
PixelValues(i) = COLORREFtoBGRx(vbWhite)
GetaHash = GetaHash & "0"
End If
Next
Debug.Print "GetaHash??????:" & GetaHash
Debug.Print "?16???? :"; Bin2Hex(GetaHash)
'Create hBitmapNew:
hBitmapNew = CreateDIBSection(hMemDC, BMI, DIB_RGB_COLORS, pvBitsNew)
If hBitmapNew = WIN32_NULL Then
Err.Raise &H80048000 Or (Err.LastDllError And &H7FFF&), TypeName(Me), "CreateDIBSection() error " & CStr(Err.LastDllError)
End If
'Copy image pixels into bitmap:
MoveMemory ByVal pvBitsNew, PixelValues(0), (UBound(PixelValues) + 1) * 4
With PICTDESC
.Size = LenB(PICTDESC)
.Type = 1 'vbPicTypeBitmap
.HBmp = hBitmapNew
End With
HRESULT = OleCreatePictureIndirect(PICTDESC, IID_IPicture, WIN32_TRUE, returnPic)
If HRESULT <> S_OK Then
DeleteObject hBitmapNew
Err.Raise HRESULT, TypeName(Me), "OleCreatePictureIndirect() error 0x" & Hex$(HRESULT)
End If
m_LonHBmp = hBitmapNew
Debug.Print "?? getahash????? ??????gdi??"
'Replace the color:
End Function
Public Function GetdHash(picPathOrPictureBox As Variant, _
Optional returnPic As StdPicture) As String
'<EhHeader>
On Error GoTo GetdHash_Err
'</EhHeader>
Dim BMI As BITMAPINFO_NOPALETTE
Dim biWidth As Long
Dim biHeight As Long
Dim PixelValues() As Long
Dim i As Long
Dim hBitmapNew As Long
Dim pvBitsNew As Long
Dim PICTDESC As PICTDESC_BMP
Dim HRESULT As Long
'FromColor = COLORREFtoBGRx(FromColor)
'ToColor = COLORREFtoBGRx(ToColor)
Dim tmpPic As StdPicture
Dim tmpPicHandle As Long
100 Select Case TypeName(picPathOrPictureBox)
Case "String"
102 If Len(Dir(picPathOrPictureBox)) <> 0 Then
104 Set tmpPic = LoadPicture(picPathOrPictureBox)
106 tmpPicHandle = tmpPic.Handle
End If
108 Case "PictureBox"
110 Set tmpPic = picPathOrPictureBox.Picture
112 tmpPicHandle = tmpPic.Handle
114 Case "Long"
116 If picPathOrPictureBox <> 0 Then
118 tmpPicHandle = picPathOrPictureBox
End If
End Select
120 With BMI.bmiHeader
'Retrieve Original.Handle's metrics:
122 .biSize = LenB(BMI.bmiHeader)
' .biBitCount = 0 'Don't fetch color table or pixels.
'
124 If GetDIBits(hMemDC, tmpPicHandle, 0, 0, WIN32_NULL, BMI, DIB_RGB_COLORS) = 0 Then
126 Err.Raise &H80048000 Or (Err.LastDllError And &H7FFF&), TypeName(Me), "GetDIBits() error " & CStr(Err.LastDllError)
End If
128 biWidth = .biWidth '???8
130 biHeight = .biHeight '???8
End With
'?????8x8??
' pic.ScaleMode = vbTwips
' pic.AutoRedraw = True
' pic.Cls
' pic.Height = pic.ScaleY(8, vbPixels, pic.ScaleMode) + (pic.Height - pic.ScaleHeight)
'
' pic.Width = pic.ScaleX(9, vbPixels, pic.ScaleMode) + (pic.Width - pic.ScaleWidth)
'
' pic.PaintPicture tmpPic, 0, 0, pic.ScaleWidth, pic.ScaleHeight
'??????dc??8*9,??8,??9
Dim DeskHwnd As Long, hDCWnd As Long, hdcMem As Long, HBmp As Long, hBmpOld As Long, sMode As Long
132 DeskHwnd = 0 ' GetDesktopWindow()
134 hDCWnd = GetDC(DeskHwnd) 'GetWindowDC(DeskHwnd) '??DC
136 hdcMem = CreateCompatibleDC(hDCWnd) '??dc????
138 HBmp = CreateCompatibleBitmap(hDCWnd, 9, 8) '??DC????
140 Call ReleaseDC(DeskHwnd, hDCWnd) '??dc
142 hBmpOld = SelectObject(hdcMem, HBmp) '???????
144 Call SetBkMode(hdcMem, TRANSPARENT) '????????
146 Call SelectObject(hMemDC, tmpPicHandle)
148 sMode = SetStretchBltMode(hdcMem, STRETCH_HALFTONE) ' makes stretching better quality
150 Call StretchBlt(hdcMem, 0, 0, 9, 8, hMemDC, 0, 0, biWidth, biHeight, SRCCOPY)
152 SetStretchBltMode hdcMem, sMode ' reset stretchmode
154 HBmp = SelectObject(hdcMem, hBmpOld)
'pic.Refresh
'??????
156 With BMI.bmiHeader
'Retrieve Original.Handle's metrics:
158 .biSize = LenB(BMI.bmiHeader)
160 .biBitCount = 0 'Don't fetch color table or pixels.
'
162 If GetDIBits(hMemDC, HBmp, 0, 0, WIN32_NULL, BMI, DIB_RGB_COLORS) = 0 Then
164 Err.Raise &H80048000 Or (Err.LastDllError And &H7FFF&), TypeName(Me), "GetDIBits() error " & CStr(Err.LastDllError)
End If
166 biWidth = .biWidth '???9
168 biHeight = .biHeight '???8
'Retrieve Original.Handle's pixel data as 32-bit RGB values:
170 .biBitCount = 32
172 .biCompression = 0 'BI_RGB
'No padding required since we are using 32-bit (DWORD) pixels:
' tmpHandle = CreateCompatibleBitmap(hBMPhDC, biWidth, biHeight) '??????
' hBmpPrev = SelectObject(hBMPhDC, tmpHandle)
174 ReDim PixelValues(biWidth * biHeight - 1) '????
176 If GetDIBits(hMemDC, HBmp, 0, biHeight, PixelValues(0), BMI, DIB_RGB_COLORS) = 0 Then
178 Err.Raise &H80048000 Or (Err.LastDllError And &H7FFF&), TypeName(Me), "GetDIBits() error " & CStr(Err.LastDllError)
End If
End With
180 Call DeleteObject(HBmp)
182 Call DeleteDC(hdcMem)
'????
Dim A As RGBQUAD, Gray As Long, totleGray As Long, avgGray As Long
184 For i = 0 To UBound(PixelValues)
186 A = COLORREFtoRGBQUAD(PixelValues(i))
Dim GrayColor As Long
'Debug.Print "??" & a.rgbRed * 0.3; a.rgbGreen * 0.59; a.rgbBlue * 0.11
188 Gray = A.rgbRed * 0.3 + A.rgbGreen * 0.59 + A.rgbBlue * 0.11
190 GrayColor = RGB(A.rgbRed * 0.3, A.rgbGreen * 0.59, A.rgbBlue * 0.11)
192 totleGray = totleGray + Gray
194 PixelValues(i) = COLORREFtoBGRx(Gray)
Next
196 avgGray = totleGray / UBound(PixelValues) + 1 '??64?
' Debug.Print "?????:" & avgGray
'????,??????????1,?????0
Dim x As Integer, y As Integer
198 For y = 0 To 7
200 For x = 0 To 7
202 If PixelValues(9 * y + x) > PixelValues(9 * y + x + 1) Then
204 PixelValues(9 * y + x) = COLORREFtoBGRx(vbBlack)
206 GetdHash = GetdHash & "1"
Else
208 PixelValues(9 * y + x) = COLORREFtoBGRx(vbWhite)
210 GetdHash = GetdHash & "0"
End If
212 Next x
214 Next y
' Debug.Print "GetdHash??????:" & GetdHash
'Create hBitmapNew:
216 hBitmapNew = CreateDIBSection(hMemDC, BMI, DIB_RGB_COLORS, pvBitsNew)
218 If hBitmapNew = WIN32_NULL Then
220 Err.Raise &H80048000 Or (Err.LastDllError And &H7FFF&), TypeName(Me), "CreateDIBSection() error " & CStr(Err.LastDllError)
End If
'Copy image pixels into bitmap:
222 MoveMemory ByVal pvBitsNew, PixelValues(0), (UBound(PixelValues) + 1) * 4
224 With PICTDESC
226 .Size = LenB(PICTDESC)
228 .Type = 1 'vbPicTypeBitmap
230 .HBmp = hBitmapNew
End With
232 HRESULT = OleCreatePictureIndirect(PICTDESC, IID_IPicture, WIN32_TRUE, returnPic)
'?????????
234 If HRESULT <> S_OK Then
236 DeleteObject hBitmapNew
238 Err.Raise HRESULT, TypeName(Me), "OleCreatePictureIndirect() error 0x" & Hex$(HRESULT)
End If
'Replace the color:
m_LonHBmp = hBitmapNew
Debug.Print "?? getdhash????? ??????gdi??"
'<EhFooter>
Exit Function
GetdHash_Err:
Err.Raise vbObjectError + 100, _
"scrcpy??????.cls????.GetdHash", _
"cls???? component failure"
'</EhFooter>
End Function
'<CSCM>
'--------------------------------------------------------------------------------
' Project : ??1
' Procedure : COLORREFtoBGRx
' Description: [type_description_here]
' Created by : Project Administrator
' Machine : PC-20200730JERU
' Date-Time : 5/17/2022-10:15:31
'
' Parameters : COLORREF (Long)
'--------------------------------------------------------------------------------
'</CSCM>
Private Function COLORREFtoBGRx(ByVal COLORREF As Long) As Long
COLORREFtoBGRx = (COLORREF And &HFF&) * &H10000 Or (COLORREF And &HFF00&) Or COLORREF \ &H10000
End Function
'<CSCM>
'--------------------------------------------------------------------------------
' Project : ??1
' Procedure : Class_Initialize
' Description: [type_description_here]
' Created by : Project Administrator
' Machine : PC-20200730JERU
' Date-Time : 5/17/2022-10:15:31
'
' Parameters :
'--------------------------------------------------------------------------------
'</CSCM>
Private Sub Class_Initialize()
Dim hScreenDC As Long
hScreenDC = GetDC(WIN32_NULL)
hMemDC = CreateCompatibleDC(hScreenDC)
ReleaseDC WIN32_NULL, hScreenDC
CLSIDFromString StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture
End Sub
'<CSCM>
'--------------------------------------------------------------------------------
' Project : ??1
' Procedure : Class_Terminate
' Description: [type_description_here]
' Created by : Project Administrator
' Machine : PC-20200730JERU
' Date-Time : 5/17/2022-10:15:31
'
' Parameters :
'--------------------------------------------------------------------------------
'</CSCM>
Private Sub Class_Terminate()
DeleteDC hMemDC
End Sub
'<CSCM>
'--------------------------------------------------------------------------------
' Project : ??1
' Procedure : COLORREFtoRGBQUAD
' Description: [type_description_here]
' Created by : Project Administrator
' Machine : PC-20200730JERU
' Date-Time : 5/17/2022-10:15:31
'
' Parameters : COLORREF (Long)
'--------------------------------------------------------------------------------
'</CSCM>
Private Function COLORREFtoRGBQUAD(ByVal COLORREF As Long) As RGBQUAD
With COLORREFtoRGBQUAD
.rgbBlue = CByte(COLORREF \ &H10000)
.rgbGreen = CByte((COLORREF And &HFF00&) \ &H100&)
.rgbRed = CByte(COLORREF And &HFF&)
End With
End Function
Friend Function RGBColourDistance(rgb1 As RGBQUAD, RGB2 As RGBQUAD) As Double
Dim r1 As Long, R2 As Long, mR As Long
Dim g1 As Long, G2 As Long, mG As Long
Dim b1 As Long, B2 As Long, mB As Long
Dim rmean As Long
r1 = rgb1.rgbRed: R2 = RGB2.rgbRed
g1 = rgb1.rgbGreen: G2 = RGB2.rgbGreen
b1 = rgb1.rgbBlue: B2 = RGB2.rgbBlue
mR = Abs(r1 - R2)
mG = Abs(g1 - G2)
mB = Abs(b1 - B2)
rmean = (r1 + R2) / 2
Dim tmp As Long
tmp = (2 + rmean / 256) * (mR * mR) + 4 * (mG * mG) + (2 + (255 - rmean) / 256) * (mB * mB)
RGBColourDistance = Math.Sqr(tmp)
End Function
Public Function Hamming(ByVal StrA As String, ByVal StrB As String) As Long
Dim TmpBin As String
Dim i As Long
If Len(StrA) <> Len(StrB) Then
Hamming = 999
Exit Function
End If
TmpBin = Replace(StrA, "1", "")
TmpBin = Replace(TmpBin, "0", "")
If Len(TmpBin) <> 0 Then
Hamming = 999
End If
TmpBin = Replace(StrB, "1", "")
TmpBin = Replace(TmpBin, "0", "")
If Len(TmpBin) <> 0 Then
If Hamming = 0 Then 'StrA was valid
Hamming = 999
Else
Hamming = 999
End If
End If
If Hamming <> 0 Then Exit Function
For i = 1 To Len(StrA)
If Mid$(StrA, i, 1) <> Mid$(StrB, i, 1) Then
Hamming = Hamming + 1
End If
Next i
End Function
Public Function Bin2Hex(strBin As String) As String
Dim iHex As String, strBinArry(), strHex()
Dim intXh As Integer, i As Integer, j As Integer, strTmp As String
strBinArry = Array("0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111", "1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111")
strHex = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F")
'strBin = InputBox("", "", "111000111")
If Len(strBin) Mod 4 <> 0 Then strBin = String(4 - Len(strBin) Mod 4, "0") & strBin
intXh = Len(strBin) \ 4
For i = 1 To intXh
strTmp = Right(strBin, 4)
For j = 0 To 15
If strTmp = strBinArry(j) Then
iHex = strHex(j) & iHex
Exit For
End If
Next
strBin = Left(strBin, Len(strBin) - 4)
Next
Debug.Print "&H" & iHex
Bin2Hex = iHex
End Function
Public Function GetpHash(picPathOrPictureBox As Variant, _
xq As Long, _
yq As Long, _
xz As Long, _
yz As Long, _
Optional returnPic As StdPicture) As String '???????????
Dim r1 As Long, g1 As Long, b1 As Long, hse1 As Long, hse0 As Long, w_jg As Double, h_jg As Double, yn As Long, xn As Long, y1 As Long, x1 As Long, y As Long, x As Long, y2 As Long, x2 As Long
Dim hase As String, ha As String, sn As Long, n1 As Long, n2 As Long, n3 As Long, nd As Long, bgr1 As Long, bgr As Long, bgr2 As Long, bgrbgr As Long
Dim BMI As BITMAPINFO_NOPALETTE
Dim biWidth As Long
Dim biHeight As Long
Dim PixelValues() As Long
Dim i As Long
Dim hBitmapNew As Long
Dim pvBitsNew As Long
Dim PICTDESC As PICTDESC_BMP
Dim HRESULT As Long
'FromColor = COLORREFtoBGRx(FromColor)
'ToColor = COLORREFtoBGRx(ToColor)
Dim tmpPic As StdPicture
Dim tmpPicHandle As Long
Select Case TypeName(picPathOrPictureBox)
Case "String"
If Len(Dir(picPathOrPictureBox)) <> 0 Then
Set tmpPic = LoadPicture(picPathOrPictureBox)
tmpPicHandle = tmpPic.Handle
End If
Case "PictureBox"
Set tmpPic = picPathOrPictureBox.Picture
tmpPicHandle = tmpPic.Handle
Case "Long"
If picPathOrPictureBox <> 0 Then
tmpPicHandle = picPathOrPictureBox
End If
End Select
With BMI.bmiHeader
'Retrieve Original.Handle's metrics:
.biSize = LenB(BMI.bmiHeader)
' .biBitCount = 0 'Don't fetch color table or pixels.
'
If GetDIBits(hMemDC, tmpPicHandle, 0, 0, WIN32_NULL, BMI, DIB_RGB_COLORS) = 0 Then
Err.Raise &H80048000 Or (Err.LastDllError And &H7FFF&), TypeName(Me), "GetDIBits() error " & CStr(Err.LastDllError)
End If
biWidth = .biWidth '
biHeight = .biHeight '
.biBitCount = 32
.biCompression = 0 'BI_RGB
'No padding required since we are using 32-bit (DWORD) pixels:
' tmpHandle = CreateCompatibleBitmap(hBMPhDC, biWidth, biHeight) '??????
' hBmpPrev = SelectObject(hBMPhDC, tmpHandle)
ReDim PixelValues(biWidth * biHeight - 1) '????
If GetDIBits(hMemDC, tmpPicHandle, 0, biHeight, PixelValues(0), BMI, DIB_RGB_COLORS) = 0 Then
Err.Raise &H80048000 Or (Err.LastDllError And &H7FFF&), TypeName(Me), "GetDIBits() error " & CStr(Err.LastDllError)
End If
End With
' ????.??????????9?,?8?. ?????????????.??????hash???.
Dim A As RGBQUAD, Gray As Long, totleGray As Long, avgGray As Long
sn = 64 '???8*8????.???????
w_jg = (xz - xq) / 9
h_jg = (yz - yq) / 8
hase = ""
'???72???.???????????.??????.
For yn = 1 To 8
ha = ""
For xn = 1 To 9
x1 = xq + Round(w_jg * (xn - 1))
y1 = yq + Round(h_jg * (yn - 1))
x2 = xq + Round(w_jg * xn)
y2 = yq + Round(h_jg * yn)
n1 = 0
bgrbgr = 0
For y = y1 To y2 - 1
For x = x1 To x2 - 1
i = (biHeight - y - 1) * biWidth + (x)
A = COLORREFtoRGBQUAD(PixelValues(i))
'a.rgbRed * 0.3 + a.rgbGreen * 0.59 + a.rgbBlue * 0.11 '????
bgr = (A.rgbBlue \ sn) * sn * 0.11 + (A.rgbGreen \ sn) * sn * 0.59 + (A.rgbRed \ sn) * sn * 0.3
PixelValues(i) = COLORREFtoBGRx(vbRed)
bgrbgr = bgrbgr + (bgr \ sn) * sn '???
n1 = n1 + 1
Next x
Next y
bgr2 = bgrbgr / n1
Dim GrayColor As Long
GrayColor = RGB(bgr2, bgr2, bgr2)
PixelValues(i) = COLORREFtoBGRx(Gray)
If xn > 1 Then
If bgr1 <= bgr2 Then
ha = ha & "1"
Else: ha = ha & "0"
End If
End If
bgr1 = bgr2
Next xn
' Sheet1.Cells(24 + yf, 6) = ha1
hase = hase & ha
Next yn
GetpHash = hase
Debug.Print "GetpHash??????:" & GetpHash
'Create hBitmapNew:
hBitmapNew = CreateDIBSection(hMemDC, BMI, DIB_RGB_COLORS, pvBitsNew)
If hBitmapNew = WIN32_NULL Then
Err.Raise &H80048000 Or (Err.LastDllError And &H7FFF&), TypeName(Me), "CreateDIBSection() error " & CStr(Err.LastDllError)
End If
'Copy image pixels into bitmap:
MoveMemory ByVal pvBitsNew, PixelValues(0), (UBound(PixelValues) + 1) * 4
With PICTDESC
.Size = LenB(PICTDESC)
.Type = 1 'vbPicTypeBitmap
.HBmp = hBitmapNew
End With
HRESULT = OleCreatePictureIndirect(PICTDESC, IID_IPicture, WIN32_TRUE, returnPic)
If HRESULT <> S_OK Then
DeleteObject hBitmapNew
Err.Raise HRESULT, TypeName(Me), "OleCreatePictureIndirect() error 0x" & Hex$(HRESULT)
End If
m_LonHBmp = hBitmapNew
Debug.Print "?? getphash????? ??????gdi??"
'Replace the color:
End Function
-
Mar 18th, 2024, 09:43 AM
#3
Fanatic Member
Re: Image Processing: Image similarity algorithms aHash, dHash, pHash
I am interested in these algorithms and their applications.
Do you have any samples of these algos in usage? There are many "?" characters in your posted code which make it difficult to work with.
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|
Reply With Quote