Results 1 to 3 of 3

Thread: Image Processing: Image similarity algorithms aHash, dHash, pHash

  1. #1

    Thread Starter
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    683

    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

  2. #2

    Thread Starter
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    683

    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

  3. #3
    Hyperactive Member
    Join Date
    Aug 2011
    Location
    Palm Coast, FL
    Posts
    506

    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
  •  



Click Here to Expand Forum to Full Width