Создать массив координат изображения

MaxRobotist

В предыдущих сериях... Разбить рисунок на точки с координатами Нахождение самых встречающихся 5 цветов на изображенииВопрос теперь в следующем:
Кликните здесь для просмотра всего текста
 Dim Color11() As String
    Private Sub traect_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles traect.Click
        Try
            image1 = New Bitmap("C:\Users.jpg", True)
 
            Dim xi, yi, b1 As Integer
 
            For xi = 0 To image1.Width - 1               
                For yi = 0 To image1.Height - 1
                    Dim pixelColor As Color = image1.GetPixel(xi, yi)   пробегаем по рисунку и берем цвет каждого пикселя
 
                    If Color.op_Equality(pixelColor, color1) Then        сравниваем цвет пикселя с заранее найденным color1
                        b1 = b1 + 1          счетчик элементов массива
                        ReDim Preserve Color11(b1)      переписываем размерность
                        Color11(b1) = xi & "  " & yi       записываем строку в массив 
                        image1.SetPixel(xi, yi, Color.Black)   заливаем этот пиксель черным
                    End If
Как сделать массив в котором будут координаты точек в виде переменных. А именно требуется сравнивать пример:
1 элемент x1   y1
2 элемент x2   y2
ЕСЛИ х1 плюс минус 3 = x2  И  y1 плюс минус 3 = y2 ТО записать в Другой массив 1 элемент x1  y1  0  Добавилось z
                                                                               2 элемент x2  y2  0
ИНАЧЕ записать в Другой массив 1 элемент  x1  y1  0
                                          x1  y1  20   это просто число 20, всегда одинаковое
                   несколько строк, вида  30  40  40  всегда одинаковые
                                         160  50  100    всегда одинаковые
                                         250  180  200    всегда одинаковые
                                          x2   y2   20
                               2 элемент  x2   y2  0
Может быть нужно создавать 2 массива X и Y производить манипуляции а потом как то склеивать?
5 ответов

MaxRobotist

Попробовал изобразить то что хочу получить


MaxRobotist

пробовал так
Кликните здесь для просмотра всего текста
Dim Color11(2)() As Integer    типа 2 мерный массив
    Private Sub traect_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles traect.Click
 
        Try
            image1 = New Bitmap("C:\Users1.jpg", True)
 
            Dim xi, yi, b1 As Integer
 
            For xi = 0 To image1.Width - 1
                For yi = 0 To image1.Height - 1
                    Dim pixelColor As Color = image1.GetPixel(xi, yi)
 
                    If Color.op_Equality(pixelColor, color1) Then
                        b1 = b1 + 1
                        ReDim Preserve Color11(1)(b1)  меняем размерность первого столбца
                        Color11(1)(b1) = xi    записывает в
                        ReDim Preserve Color11(2)(b1)  меняем размерность второго столбца
                        Color11(2)(b1) = yi
                        image1.SetPixel(xi, yi, Color.Black)
                    End If
НЕ РАБОТАЕТ при запросе
            For i = 1 To b1
                ListBox2.Items.Add(Color11(1)(b1))
            Next
выдает кучу одинаковых элементов


MaxRobotist

Вижу никто не стал заморачиваться темой Колдую сам, практически у цели ПОДСКАЖИТЕ ПОЖАЛУЙСТА Как поменять размерность после Else
Кликните здесь для просмотра всего текста
    Dim Traector11() As String
    Private Sub traector2_Click(sender As Object, e As EventArgs) Handles traector2.Click
        For i = 0 To b1 - 1
 
            If ColorX11(i) = ColorX11(i + 1) And ColorY11(i) + 1 = ColorY11(i + 1) Then
                ReDim Preserve Traector11(i)
                Traector11(i) = ColorX11(i) & "  " & ColorY11(i) & "bez otr"
            Else
                ReDim Preserve Traector11(i)
                Traector11(i) = ColorX11(i) & "  " & ColorY11(i) & "        otryv"
 
                ReDim Preserve Traector11(i + 1)
                Traector11(i + 1) = "otryv"
            End If
        Next
        For i = 0 To b1 - 1
            ListBox14.Items.Add(Traector11(i))
        Next
    End Sub
ReDim Preserve Traector11(i + 1) Traector11(i + 1) = "otryv" НЕ ПОМОГАЕТ А нужно что бы добавлялось несколько строк, в моем коде они просто переписываются следующей итерациейb1 размер массивов ColorX11 и ColorY11(i) - координаты точек одного цвета


MaxRobotist

Предлагаю код по переводу растра в трехмерный массив, обработка массива (не приводится) и перевод преобразованного массива в растр. Типичная процедура для формирования разного рода визуальных эффектов. Хотя код рабочий, но его производительность невысока. Для повышения производительности нужно отказаться от использования GetPixel/SetPixel. Если есть интерес то используйте поиск по следующим ключевым словам: класс BitmapData, LockBits, UnlockBits, Marshal.Copy.
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
    Dim bmp As Bitmap = loadBitmap("q14.bmp")
    If bmp IsNot Nothing Then
        Dim px1(,,) As Byte
        'переводим в цифру
        px1 = BmpToPx(bmp)
        'выполняем необходимые преобразования с px1
       '…….
        'и формируем Bitmap нужного размера
        Dim bmp3 As Bitmap = PxToBmp(px1, bmp.Width, bmp.Height)
        'выводим картинку
        PictureBox1.Image = bmp3
        'сохраняем
        bmp3.Save("C:\03\qq01.jpg", ImageFormat.Jpeg)
    End If
End Sub
'…
''' <summary>
''' возвращает Bitmap и освобождает файл nmFile
''' </summary>
Public Function loadBitmap(ByVal nmFile As String) As Bitmap
    Dim img As Bitmap
    If File.Exists(nmFile) Then
        Using fs As New FileStream(nmFile, FileMode.Open, FileAccess.Read, FileShare.Read)
            img = New Bitmap(fs)
        End Using
    Else
        img = Nothing
    End If
    Return img
End Function
''' <summary>
''' на входе Bitmap, на выходе трехмерный массив (тип Byte)
''' </summary>
Public Function BmpToPx(ByVal img As Bitmap) As Byte(,,)
    Dim w As Integer = img.Width
    Dim h As Integer = img.Height
    Dim inf As Byte(,,) = New Byte(2, h - 1, w - 1) {}
    Dim cc As Color
    For i = 0 To h - 1 'строка
        For j = 0 To w - 1 'столбец
            cc = img.GetPixel(j, i)
            inf(0, i, j) = cc.R 'для первого измерения 0 = значения R составляющей цвета RGB
            inf(1, i, j) = cc.G 'для первого измерения 1 = значения G составляющей цвета RGB
            inf(2, i, j) = cc.B 'для первого измерения 2 = значения B составляющей цвета RGB
        Next
    Next
    Return inf
End Function
''' <summary>
''' на входе трехмерный массив (тип Byte), значения ширины и высоты формируемого рисунка (px);
''' на выходе Bitmap
''' </summary>
Public Function PxToBmp(ByVal inf As Byte(,,), ByVal w As Integer, ByVal h As Integer) As Bitmap
    Dim cc As Color
    Dim img As New Bitmap(w, h)
    For i = 0 To h - 1 'строка
        For j = 0 To w - 1 'столбец
            cc = Color.FromArgb(inf(0, i, j), inf(1, i, j), inf(2, i, j))
            img.SetPixel(j, i, cc)
        Next
    Next
    Return img
End Function
PS. Не очень понял существо вашей задачи, но надеюсь что мой ответ в какой-то степени вам поможет.


MaxRobotist

Спасибо что откликнулись. Задача не из простых Кое что возьму из вашего примера!! Вот это удалось наделать, многие помогали , долго считает но результат радует
Кликните здесь для просмотра всего текста
image1 = New Bitmap("C:\1.jpg", True)
            Dim xi, yi As Integer
            Dim allColor As New List(Of Integer)
            For xi = 0 To image1.Width - 1
                For yi = 0 To image1.Height - 1
                    Dim pixelColor As Color = image1.GetPixel(xi, yi)
                    allColor.Add(pixelColor.ToArgb)
                Next
            Next
            Dim clrs() = (From cc In allColor Group cc By cc Into Group Order By Group.Count Descending).ToArray
            color1 = Color.FromArgb(clrs(0).cc)
ищу самый часто встречающийся цвет на изображении
Кликните здесь для просмотра всего текста
            image1 = New Bitmap("C:\1.jpg", True)
            Dim xi, yi As Integer
            For xi = 0 To image1.Width - 1
                For yi = 0 To image1.Height - 1
                    Dim pixelColor As Color = image1.GetPixel(xi, yi)
                    If Color.op_Equality(pixelColor, color1) Then
                        b1 = b1 + 1
                        ReDim Preserve *********(2, b1)
                        *********(1, b1) = xi
                        *********(2, b1) = yi
                        image1.SetPixel(xi, yi, Color.Black)
                    End If
теперь нахожу координаты пикселей с этим цветом
Кликните здесь для просмотра всего текста
        Dim m As Integer = 0
        For i = 0 To b1 - 1
            If *********(1, i) = *********(1, i + 1) And *********(2, i) + 1 = *********(2, i + 1) Then
                m = m + 1
                ReDim Preserve Traector11(3, m)
                Traector11(1, m) = *********(1, i) & "  00  bez otr"
                Traector11(2, m) = *********(2, i)
                Traector11(3, m) = "00"
            Else
                ReDim Preserve Traector11(3, m)
                Traector11(1, m) = "111111111111111"
                Traector11(2, m) = "111111111111111"
                Traector11(3, m) = "00"
                ReDim Preserve Traector11(3, m + 1)
                Traector11(1, m + 1) = "OOOOOOOOOO"
                Traector11(2, m + 1) = "OOOOOOOOOO"
                Traector11(3, m + 1) = 7777
                ReDim Preserve Traector11(3, m + 2)       МОЖЕТ Я ЗРЯ ТРИ РАЗА ИСПОЛЬЗУЮ  ReDim Preserve ???
                Traector11(1, m + 2) = "AAAAAAAAAA"
                Traector11(2, m + 2) = "AAAAAAAAAA"
                Traector11(3, m + 2) = "00"
                m = m + 2
            End If
        Next
а тут переписываю массив, делая его трехмерным, с теми условия которые мне нужны P.S. спасибо всем кто помогал проект завершен на 80%