快速定位大图中样本图坐标：VB.NET代码容差与性能优化需求

需求背景 #

需实现大尺寸图像中样本图像坐标的快速定位，目前基于VB.NET编写了两类代码，存在性能、匹配逻辑缺陷等问题，具体如下：

第一版代码（整数RGB值，无容差匹配） #

Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
        Dim intMain() As Integer = GetRgbValues(picMain.Image)
        Dim intTemp() As Integer = GetRgbValues(picTemp.Image)
        Dim ArrTemp = SplitArrayBySpecifiedStep(intTemp, picTemp.Image.Width)
        Dim FirstLine As Integer() = ArrTemp(0)
        Dim IndexOfFirstRow As Integer() = GetIndexsBySpecifiedOrder(intMain, FirstLine)
        '目前这部分运行正常，但后续逻辑需验证
        Dim ArrMain = SplitArrayBySpecifiedStep(intMain, picMain.Image.Width)
        Dim Coordinates_X_Y As New List(Of Rectangle)
        For Each StartFind In IndexOfFirstRow
            Dim i = StartFind Mod picMain.Image.Width
            Dim t = StartFind \ picMain.Image.Width
            Dim isY As Integer = t
            Dim IsX As Integer = i
            Dim thisIsIt As Integer = 0
            For startCheck = 1 To ArrTemp.Length - 1
                t += 1
                Dim gg = ArrMain(t).Skip(i).Take(ArrTemp(startCheck).Length).Select(Function(h) h).ToArray
                If ArraysSimilarity(gg, ArrTemp(startCheck)) Then
                    thisIsIt += 1
                End If
            Next
            If thisIsIt = ArrTemp.Length - 1 Then
                Dim rec As New Rectangle(IsX, isY, picTemp.Image.Width, picTemp.Image.Height)
                Coordinates_X_Y.Add(rec)
            End If
        Next
        For Each Rec In Coordinates_X_Y
            Dim bt As New Bitmap(picMain.Image)
            Dim g As Graphics = Graphics.FromImage(bt)
            g.DrawRectangle(New Pen(Color.Red, 3), New Rectangle(Rec.X, Rec.Y, Rec.Width, Rec.Height))
            picMain.Image = bt
            g.Dispose()
            ListBox1.Items.Add(Rec.X & "," & Rec.Y)
        Next

    End Sub
    Function ArraysSimilarity(InArray As Integer(), Simiilar As Integer(), Optional tolerance As Integer = 10) As Boolean
        ArraysSimilarity = InArray.SequenceEqual(Simiilar)
    End Function
    Function SplitArrayBySpecifiedStep(InArray As Integer(), ByStep As Integer) As Integer()()
        SplitArrayBySpecifiedStep = InArray.Select(Function(num, index) New With {.num = num, .index = index}) _
             .GroupBy(Function(x) x.index \ ByStep) _
             .Select(Function(g) g.Select(Function(x) x.num).ToArray).ToArray
    End Function
    Function GetIndexsBySpecifiedOrder(inArray As Integer(), SpecifiedOrder As Integer()) As Integer()
        GetIndexsBySpecifiedOrder = inArray.Select(Function(value, index) index) _
                    .Where(Function(index) inArray(index) = SpecifiedOrder(0) AndAlso
                                          If(index + SpecifiedOrder.Length <= inArray.Length,
                                             Enumerable.SequenceEqual(inArray.Skip(index).Take(SpecifiedOrder.Length), SpecifiedOrder),
                                             False)) _
                    .ToArray()
    End Function
    Private Function GetRgbValues(inBitmap As Bitmap) As Integer()
        Dim recBitmap As New Rectangle(0, 0, inBitmap.Width, inBitmap.Height)
        Dim DataMain As System.Drawing.Imaging.BitmapData = inBitmap.LockBits(recBitmap, Drawing.Imaging.ImageLockMode.ReadWrite, Imaging.PixelFormat.Format32bppArgb)
        Dim ptr As IntPtr = DataMain.Scan0
        Dim bytes As Integer = Math.Abs(DataMain.Stride) * recBitmap.Height

        Dim rgbValues(bytes / 4 - 1) As Integer
        System.Runtime.InteropServices.Marshal.Copy(ptr, rgbValues, 0, rgbValues.Length)
        inBitmap.UnlockBits(DataMain)
        Return rgbValues
    End Function

第一版代码问题 #

• 通过整数类型获取RGB值，无法实现带容差的颜色匹配，ArraysSimilarity函数仅做严格相等判断
• 运行性能较差，无法满足快速定位需求

新版代码（字符串拼接匹配，仍有缺陷） #

Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
    Dim pictureBoxMain As PictureBox = picMain
    Dim PictureBoxTemp As PictureBox = picTemp
    Dim intMain As String = GetRgbOfString(pictureBoxMain.Image)
    Dim intTemp() As String = GetArrRgbOfString(PictureBoxTemp.Image, PictureBoxTemp.Image.Width)
    Dim firstRowsRgb As New List(Of Integer)
    Dim Coordinates_X_Y As New List(Of Rectangle)
    Dim i As Integer = 0
    Dim FirstLine As String = intTemp(0)
    Do
        i = InStr(i + 1, intMain, FirstLine)
        If i = 0 Then
            Exit Do
        Else
            Dim XY() As Integer = FindOtherRows(i, intMain, pictureBoxMain.Image.Width, intTemp)
            If XY IsNot Nothing Then
                Dim rec As New Rectangle(XY(0), XY(1), PictureBoxTemp.Image.Width, PictureBoxTemp.Image.Height)
                Coordinates_X_Y.Add(rec)
            End If
        End If
    Loop
    For Each Rec In Coordinates_X_Y
        Dim bt As New Bitmap(pictureBoxMain.Image)
        Dim g As Graphics = Graphics.FromImage(bt)
        g.DrawRectangle(New Pen(Color.Red, 3), New Rectangle(Rec.X, Rec.Y, Rec.Width, Rec.Height))
        pictureBoxMain.Image = bt
        g.Dispose()
        ListBox1.Items.Add(Rec.X & "," & Rec.Y)
    Next
End Sub
Function FindOtherRows(start As Integer, InMain As String, WidthMain As Integer, RowsFind As String()) As Integer()
    '此处的核心匹配逻辑无法识别超过2行的内容
    '容差设置至关重要，烦请检查该部分
    Dim thisIsIt As Integer = 0
    Dim GetSeparator As Integer = InMain.Take(start).Count(Function(c) c = "|")
    For Row = 1 To RowsFind.Length - 1
        Dim Result3 As String = String.Join("|", InMain.Split("|").Skip(GetSeparator + WidthMain).Take(Split(RowsFind(Row), "|").Length))
        Dim stt6 As String = Result3 & vbNewLine & RowsFind(Row)
        If Result3 = RowsFind(Row) Then thisIsIt += 1 ' 此处需要添加容差逻辑
    Next
    If thisIsIt > 0 Then
        Return {(GetSeparator Mod WidthMain), (GetSeparator \ WidthMain)}
    Else
        Return Nothing
    End If
End Function
Private Function GetRgbOfString(inBitmap As Bitmap) As String
    Dim recBitmap As New Rectangle(0, 0, inBitmap.Width, inBitmap.Height)
    Dim DataMain As System.Drawing.Imaging.BitmapData = inBitmap.LockBits(recBitmap, Drawing.Imaging.ImageLockMode.ReadWrite, Imaging.PixelFormat.Format32bppArgb)
    Dim ptr As IntPtr = DataMain.Scan0
    Dim bytes As Integer = Math.Abs(DataMain.Stride) * recBitmap.Height
    Dim rgbValues(bytes / 4 - 1) As Integer
    System.Runtime.InteropServices.Marshal.Copy(ptr, rgbValues, 0, rgbValues.Length)
    inBitmap.UnlockBits(DataMain)
    '  Dim Resul As String = System.Text.Encoding.Default.GetString(rgbValues)
    GetRgbOfString = String.Join("|", rgbValues)
End Function
Private Function GetArrRgbOfString(inBitmap As Bitmap, SplitBy As Integer) As String()
    Dim recBitmap As New Rectangle(0, 0, inBitmap.Width, inBitmap.Height)
    Dim DataMain As System.Drawing.Imaging.BitmapData = inBitmap.LockBits(recBitmap, Drawing.Imaging.ImageLockMode.ReadWrite, Imaging.PixelFormat.Format32bppArgb)
    Dim ptr As IntPtr = DataMain.Scan0
    Dim bytes As Integer = Math.Abs(DataMain.Stride) * recBitmap.Height
    Dim rgbValues(bytes / 4 - 1) As Integer
    System.Runtime.InteropServices.Marshal.Copy(ptr, rgbValues, 0, rgbValues.Length)
    inBitmap.UnlockBits(DataMain)
    Return SplitArrayBySpecifiedStep(rgbValues, SplitBy)
End Function
Function SplitArrayBySpecifiedStep(InArray As Integer(), ByStep As Integer) As String()
    Dim Result = InArray.Select(Function(s, i) New With {s, i}).GroupBy(Function(x) x.i \ ByStep).Select(Function(g) String.Join("|", g.Select(Function(x) x.s))).ToArray
    Return Result
End Function

新版代码问题 #

• 速度有所提升，可在10秒内定位1366×768像素大图中的4个目标，但仍需优化以达到最佳速度
• FindOtherRows函数无法识别超过2行的样本图像，核心匹配逻辑存在缺陷
• 未实现容差匹配，仅做字符串严格相等判断，需补充容差逻辑

内容的提问来源于stack exchange，提问作者Mansour Dalir