how can fast find small picture in screen

Option Explicit
 
Private Declare 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 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 Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbAlpha As Byte   '透明通道
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
 
Public Type mRect
    Top  As Long
  
    Left As Long
    
    w As Long
    h As Long
End Type
 
Public Type mOffset
    X  As Long
  
    Y As Long
 
End Type
 
'图片文件头
Dim BI  As BITMAPINFO
Dim BI1 As BITMAPINFO
 
 
'在图片1中查找图片2，是否找出全部
Public Function FindPic(P1 As VB.PictureBox, P2 As VB.PictureBox, Offset As mOffset, Optional ColorDeviation As Byte = 100, Optional Similarity As Single = 0.9, Optional FindAll As Boolean = False) As Boolean
    Dim mSimilarity As Long
    
    Dim w      As Long, h As Long, i As Long, J As Long
    Dim W2     As Long, H2 As Long, I2 As Long, J2 As Long
 
    Dim zPic() As Byte, fPic() As Byte
    Dim R      As Byte, G As Byte, B As Byte
 
    '1 获得图片2数据
    W2 = frmain.ScaleX(P2.Picture.Width, vbHimetric, vbPixels)
    H2 = frmain.ScaleY(P2.Picture.height, 8, 3)
 
    With BI.bmiHeader
        .biSize = Len(BI.bmiHeader)
        .biWidth = W2
        .biHeight = -H2
        .biBitCount = 32
        .biPlanes = 1
    End With
 
    ReDim zPic(3, W2 - 1, H2 - 1)
 
    i = GetDIBits(P2.hDC, P2.Picture.Handle, 0, H2, zPic(0, 0, 0), BI, 0)
    'Debug.Print I
    '如果在这里处理一下，图像大的话，可能会快一点。
 
    '2 获得图片1数据
    w = frmain.ScaleX(P1.Picture.Width, vbHimetric, vbPixels)
    h = frmain.ScaleY(P1.Picture.height, 8, 3)
 
    With BI1.bmiHeader
        .biSize = Len(BI1.bmiHeader)
        .biWidth = w
        .biHeight = -h
        .biBitCount = 32
        .biPlanes = 1
    End With
 
    '    frmain.fdpic.height = P2.height
    '    frmain.fdpic.width = P2.width
    '    frmain.fdpic.ScaleMode = vbPixels
 
    '    For J2 = 0 To H2 - 2 '循环判断小图片
    '        For I2 = 0 To W2 - 2
    '            frmain.fdpic.PSet (I2, J2), rgb(zPic(2, I2, J2), zPic(1, I2, J2), zPic(0, I2, J2))
    '            VBA.DoEvents
    '        Next I2
    '    Next J2
    '
    '    frmain.fdpic.Refresh
 
    ReDim fPic(3, w - 1, h - 1)
    i = GetDIBits(P1.hDC, P1.Picture.Handle, 0, h, fPic(0, 0, 0), BI1, 0)
    'Debug.Print I
 
    '分析查找
    For J = 0 To h - H2 - 1
        For i = 0 To w - W2 - 1
            VBA.DoEvents
 
            For J2 = 0 To H2 - 2 '循环判断小图片
                For I2 = 0 To W2 - 2
                
                    'If zPic(2, I2, J2) + 50 < fPic(2, I + I2, J + J2) Or fPic(2, I + I2, J + J2) < zPic(2, I2, J2) Then GoTo ExitLine: 'R
                    ' If zPic(1, I2, J2) + 50 < fPic(1, I + I2, J + J2) Or fPic(1, I + I2, J + J2) < zPic(1, I2, J2) Then GoTo ExitLine: 'G
                    ' If zPic(0, I2, J2) + 50 < fPic(0, I + I2, J + J2) Or fPic(0, I + I2, J + J2) < zPic(0, I2, J2) Then GoTo ExitLine: 'B
                    If Abs(CInt(zPic(2, I2, J2)) - CInt(fPic(2, i + I2, J + J2))) > ColorDeviation Then
                        GoTo ExitLine:  'R
                    End If
 
                    If Abs(CInt(zPic(1, I2, J2)) - CInt(fPic(1, i + I2, J + J2))) > ColorDeviation Then
                        GoTo ExitLine: 'G'
                    End If
 
                    If Abs(CInt(zPic(0, I2, J2)) - CInt(fPic(0, i + I2, J + J2))) > ColorDeviation Then
                        GoTo ExitLine: 'B
                    End If
 
                    mSimilarity = mSimilarity + 1
 
                    If mSimilarity / (H2 * W2) >= Similarity Then
                      GoTo Ok:
                    End If
                
                Next I2
            Next J2
Ok:
            Debug.Print "FIND:", W2, H2
 
            Offset.X = i
            Offset.Y = J
            
            FindPic = True
            'Load frmain.Shape1(frmain.Shape1.Count)
        
'            With frmain.Shape1
'                .Move i, J, W2, H2
'                .BorderWidth = 2
'                .Visible = True
'            End With
 
            Exit Function
ExitLine:
           mSimilarity = 0
        Next i
    Next J
 
    'MsgBox "FIND" & frmain.Shape1.Count - 1 & "SAME。"
End Function
 
'Private Sub Cmd1_Click()
'    Dim Ps() As Integer     '找到图片的位置数组
'    Ps = FindPic(Pic1, Pic2)
'
'End Sub
 
'Private Sub Form_Load()
'
'    With Shape1(0)
'        .height = Pic2.height
'        .width = Pic2.width
'    End With
'
'End Sub

Public Sub TemplateMatchDib(Lwidth As Long, Lheight As Long, Temph As Long, Tempw As Long)
Dim i As Integer, j As Integer, m As Integer, n As Integer
Dim dsigmast As Double, dsigmas As Double, dsigmat As Double, r As Double
Dim LmaxWidth As Long, LmaxHeight As Long
Dim MidMatrix() As Long
ReDim MidMatrix(3, Lwidth, Lheight) As Long
 
On Error Resume Next
For i = 1 To Lwidth
For j = 1 To Lheight
For m = 1 To 3 '处理的是24位位图，可选择处理灰度图，速度会快一些
MidMatrix(m, i, j) = 255 '初始化中间矩阵
Next m
Next j
Next i
dsigmat = 0
For n = 1 To Temph - 1
For m = 1 To Tempw - 1
dsigmat = dsigmat + Val(bDATA(1, m, n)) ^ 2 '计算dsigmat
Next m
Next n
maxr = 0
For j = 1 To Lheight - Temph + 1 Step 3 '找到图象中最大相似性出现的位置
For i = 1 To Lwidth - Tempw + 1 Step 3 '此初的step改为1似乎对结果没什么影响，为3可提高速度
dsigmast = 0
dsigmas = 0 '归0
For n = 1 To Temph
For m = 1 To Tempw
dsigmas = dsigmas + (Val(iDATA(1, i + m - 1, j + n - 1)) + Val(iDATA(2, i + m - 1, j + n - 1)) + Val(iDATA(3, i + m - 1, j + n - 1)) / 3) ^ 2
dsigmast = dsigmast + (Val(iDATA(1, i + m - 1, j + n - 1)) + Val(iDATA(2, i + m - 1, j + n - 1)) + Val(iDATA(3, i + m - 1, j + n - 1)) / 3) * (Val(bDATA(1, m, n)) + Val(bDATA(1, m, n)) + Val(bDATA(1, m, n))) / 3
Next m
Next n
r = dsigmast / (Sqr(dsigmas) * Sqr(dsigmat)) '计算相似性
If r > maxr Then '与最大相似性比较
maxr = r
LmaxWidth = i
LmaxHeight = j
End If
Next i
Next j

Option Explicit
 
Private Type tPoint
    lX      As Long
    lY      As Long
End Type
 
Private Type tImageDesc ' // 32bpp only
    lWidth  As Long
    lHeight As Long
    bData() As Byte
End Type
 
Private Type RGBQUAD
    rgbBlue         As Byte
    rgbGreen        As Byte
    rgbRed          As Byte
    rgbReserved     As Byte
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 Type SAFEARRAY1D
    cDims           As Integer
    fFeatures       As Integer
    cbElements      As Long
    cLocks          As Long
    pvData          As Long
    cElements       As Long
    lLbound         As Long
End Type
 
Private Declare Function GetDIBits Lib "gdi32" ( _
                         ByVal aHDC As Long, _
                         ByVal hBitmap As Long, _
                         ByVal nStartScan As Long, _
                         ByVal nNumScans As Long, _
                         ByRef lpBits As Any, _
                         ByRef lpBI As BITMAPINFO, _
                         ByVal wUsage As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" ( _
                         ByVal hDC As Long, _
                         ByRef pBitmapInfo As BITMAPINFO, _
                         ByVal un As Long, _
                         ByRef lplpVoid As Long, _
                         ByVal handle As Long, _
                         ByVal dw As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
                         ByVal hDC As Long) As Long
Private Declare Function SaveDC Lib "gdi32" ( _
                         ByVal hDC As Long) As Long
Private Declare Function RestoreDC Lib "gdi32" ( _
                         ByVal hDC As Long, _
                         ByVal nSavedDC As Long) 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 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 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 Sub MoveArray Lib "msvbvm60" _
                    Alias "__vbaAryMove" ( _
                    ByRef Destination() As Any, _
                    ByRef Source As Any)
 
Private m_tTemplate     As tImageDesc
Private m_tMask         As tImageDesc
Private m_tScreen       As tImageDesc
Private m_hBuffer       As Long
Private m_hBufDC        As Long
Private m_tSaDesc       As SAFEARRAY1D
Private m_pSADesc       As Long
Private m_lFPS          As Long
Private m_bUnloading    As Boolean
Private m_bIsRunning    As Boolean
 
Private Sub Form_Load()
    
    InitializeScreenBuffer
    m_tTemplate = ImageDescFromFile(App.Path & "\template.bmp")
    m_tMask = ImageDescFromFile(App.Path & "\mask.bmp")
 
End Sub
 
Private Sub cmdStart_Click()
    
    If m_bIsRunning Then
        m_bIsRunning = False
        Exit Sub
    End If
    
    tmrFPS.Enabled = True
    cmdStart.Caption = "Stop"
    m_bIsRunning = True
    
    Do While m_bIsRunning
    
        FindTemplate
        m_lFPS = m_lFPS + 1
        DoEvents
        
    Loop
    
    If Not m_bUnloading Then
    
        cmdStart.Caption = "Start"
        Me.Caption = vbNullString
        tmrFPS.Enabled = False
        
    End If
    
End Sub
 
Private Sub FindTemplate()
    Dim tPos    As tPoint
    
    FillScreenBuffer
    
    tPos = FindImage(m_tScreen, 0, 0, m_tTemplate, m_tMask)
    
    Me.Cls
    
    If tPos.lX = -1 Then
        Me.Print "Not found"
    Else
        Me.Print "X = "; tPos.lX
        Me.Print "Y = "; tPos.lY
    End If
    
End Sub
 
Private Sub UninitializeScreenBuffer()
    
    m_pSADesc = 0
    
    If m_hBufDC Then
        RestoreDC m_hBufDC, -1
        DeleteDC m_hBufDC
    End If
    
    If m_hBuffer Then
        DeleteObject m_hBuffer
    End If
    
End Sub
 
Private Sub InitializeScreenBuffer()
    Dim tBI     As BITMAPINFO
    Dim pBits   As Long
    
    m_tScreen.lWidth = Screen.Width / Screen.TwipsPerPixelX
    m_tScreen.lHeight = Screen.Height / Screen.TwipsPerPixelY
    
    With tBI.bmiHeader
        .biSize = Len(tBI.bmiHeader)
        .biBitCount = 32
        .biHeight = -m_tScreen.lHeight
        .biWidth = m_tScreen.lWidth
        .biPlanes = 1
    End With
    
    m_hBuffer = CreateDIBSection(Me.hDC, tBI, 0, pBits, 0, 0)
    If m_hBuffer = 0 Then
        Err.Raise 7
    End If
    
    m_hBufDC = CreateCompatibleDC(Me.hDC)
    If m_hBufDC = 0 Then
        DeleteObject m_hBuffer: m_hBuffer = 0
        Err.Raise 7
    End If
    
    SaveDC m_hBufDC
    SelectObject m_hBufDC, m_hBuffer
    
    With m_tSaDesc
        .cDims = 1
        .fFeatures = &H11
        .cbElements = 1
        .cElements = m_tScreen.lWidth * m_tScreen.lHeight * 4
        .pvData = pBits
    End With
    
    m_pSADesc = VarPtr(m_tSaDesc)
    
    MoveArray m_tScreen.bData, m_pSADesc
    
End Sub
 
Private Sub FillScreenBuffer()
    Dim hDC As Long
    
    hDC = GetDC(0)
    BitBlt m_hBufDC, 0, 0, m_tScreen.lWidth, m_tScreen.lHeight, hDC, 0, 0, vbSrcCopy
    ReleaseDC 0, hDC
        
End Sub
 
Private Function ImageDescFromFile( _
                 ByRef sFileName As String) As tImageDesc
    Dim cPic    As StdPicture
    Dim tRet    As tImageDesc
    Dim tBI     As BITMAPINFO
    
    Set cPic = LoadPicture(sFileName)
    
    tRet.lWidth = Me.ScaleX(cPic.Width, vbHimetric, vbPixels)
    tRet.lHeight = Me.ScaleY(cPic.Height, vbHimetric, vbPixels)
    
    With tBI.bmiHeader
        .biSize = Len(tBI.bmiHeader)
        .biBitCount = 32
        .biPlanes = 1
        .biWidth = tRet.lWidth
        .biHeight = -tRet.lHeight
    End With
    
    ReDim tRet.bData(tRet.lWidth * tRet.lHeight * 4 - 1)
    
    If GetDIBits(Me.hDC, cPic.handle, 0, tRet.lHeight, tRet.bData(0), tBI, 0) = 0 Then
        Err.Raise 7
    End If
    
    ImageDescFromFile = tRet
    
End Function
 
Private Function FindImage( _
                 ByRef tImage As tImageDesc, _
                 ByVal lStartX As Long, _
                 ByVal lStartY As Long, _
                 ByRef tTemplate As tImageDesc, _
                 ByRef tMask As tImageDesc) As tPoint
    Dim lIndex1 As Long
    Dim lIndex2 As Long
    Dim lIndex3 As Long
    Dim tBPtX   As Long:    Dim tBPtY   As Long
    Dim tSPtX   As Long:    Dim tSPtY   As Long
    Dim tRet    As tPoint
    
    ' // No errors/bounds checking!
    
    tRet.lX = -1: tRet.lY = -1
    lIndex1 = (lStartY * tImage.lWidth + lStartX) * 4
    
    For tBPtY = 0 To tImage.lHeight - lStartY - tTemplate.lHeight - 1
        For tBPtX = 0 To tImage.lWidth - lStartX - tTemplate.lWidth - 1
 
            lIndex2 = 0:    lIndex3 = lIndex1
            
            For tSPtY = 0 To tTemplate.lHeight - 1
                For tSPtX = 0 To tTemplate.lWidth - 1
                
                    If tMask.bData(lIndex2) Then    ' // Test blue channel only
                        If tImage.bData(lIndex3) <> tTemplate.bData(lIndex2) Or _
                            tImage.bData(lIndex3 + 1) <> tTemplate.bData(lIndex2 + 1) Or _
                            tImage.bData(lIndex3 + 2) <> tTemplate.bData(lIndex2 + 2) Then  ' // Ignore alpha
                            GoTo next_col_check
                        End If
                    End If
                    
                    lIndex2 = lIndex2 + 4
                    lIndex3 = lIndex3 + 4
                    
                Next
                
                lIndex3 = lIndex3 + (tImage.lWidth - tTemplate.lWidth) * 4
                
            Next
            
            tRet.lX = tBPtX + lStartX
            tRet.lY = tBPtY + lStartY
            
            GoTo exit_proc
            
next_col_check:
            
            lIndex1 = lIndex1 + 4
            
        Next
        
        lIndex1 = lIndex1 + (lStartX + tTemplate.lWidth) * 4
        
    Next
    
exit_proc:
 
    FindImage = tRet
    
End Function
 
Private Sub Form_Unload( _
            ByRef Cancel As Integer)
            
    m_bUnloading = True
    m_bIsRunning = False
    UninitializeScreenBuffer
    
End Sub
 
Private Sub tmrFPS_Timer()
    Me.Caption = "FPS: " & CStr(m_lFPS)
    m_lFPS = 0
End Sub

Private Function Minimum(ParamArray Vals())
Dim n As Integer, MinVal
On Error Resume Next
    MinVal = Vals(0)
    For n = 1 To UBound(Vals)
        If Vals(n) < MinVal Then MinVal = Vals(n)
    Next n
    Minimum = MinVal
End Function
Private Function Maximum(ParamArray Vals())
Dim n As Integer, MaxVal
On Error Resume Next
    MaxVal = Vals(0)
    For n = 1 To UBound(Vals)
        If Vals(n) > MaxVal Then MaxVal = Vals(n)
    Next n
    Maximum = MaxVal
End Function
 
Private Sub c2hsb(ByVal clr As Long)
Dim MyR As Single, MyG As Single, MyB As Single
Dim Max As Single, Min As Single
Dim MyS As Single
Dim Delta As Single, MyVal As Single
Dim cc As String * 6
Dim r1, g1, b1 As Byte
On Error Resume Next
    cc = Right("000000" + Hex$(clr), 6)
    b1 = Val("&H" + Left(cc, 2))
    g1 = Val("&H" + Mid(cc, 3, 2))
    r1 = Val("&H" + Right(cc, 2))
    MyR = r1 / 255: MyG = g1 / 255: MyB = b1 / 255
    Max = Maximum(MyR, MyG, MyB)
    Min = Minimum(MyR, MyG, MyB)
    hsbB = Int(Max * 100)
    If Max <> 0 Then
        MyS = (Max - Min) / Max * 100
    Else
        MyS = 0
    End If
    hsbS = MyS
    If hsbS = 0 Then
        hsbH = 0
    Else
        Delta = Max - Min
        Select Case Max
        Case MyR
            MyVal = (MyG - MyB) / Delta
        Case MyG
            MyVal = 2 + (MyB - MyR) / Delta
        Case MyB
            MyVal = 4 + (MyR - MyG) / Delta
        End Select
        MyVal = MyVal * 60
        If MyVal < 0 Then MyVal = MyVal + 360
        hsbH = MyVal
    End If
'   Debug.Print "hsb="; hsbH; " "; hsbS; " "; hsbB
End Sub
 
Private Function ColorDistance(ByVal c1 As Long, ByVal c2 As Long) As Long
Dim cd As Long
Dim h1, s1, b1, h2, s2, b2 As Single
On Error Resume Next
    If c1 = -1 Or c2 = -1 Then
        ColorDistance = 1000000
        Exit Function
    End If
    c2hsb (c1)
    h1 = hsbH / 360
    s1 = hsbS
    b1 = hsbB
    c2hsb (c2)
    h2 = hsbH / 360
    s2 = hsbS
    b2 = hsbB
    cd = Abs(h1 - h2)
    cd = cd + Abs(s1 - s2)
    cd = cd + Abs(b1 - b2)
    ColorDistance = cd
End Function