Подсчет объектов на изображении

[Sergey89]

Программа выдает ошибку "Run-time error "28" Недостаточно места в стеке" в выделенном месте. Когда пропускаю ошибку выдает неправильный результат. Подскажите, что не так?

Код:
_______________________________________________
Dim mask()
Dim I



Private Sub Picture1_Click()

Dim x As Integer, y As Integer
Dim w, h

w = Picture1.ScaleWidth - 1
h = Picture1.ScaleHeight - 1

ReDim mask(w, h)

For y = 1 To h - 1
For x = 1 To w - 1

If mask(x, y) = 0 And Picture1.Point(x, y) = vbBlack Then
Mk x, y
I = I + 1
End If

Next x
Next y
Picture1.Refresh
Caption = I
End Sub


Function Mk(x0, y0)
'On Error Resume Next
Dim x, y

If Picture1.Point(x0, y0) = vbWhite Then Exit Function

mask(x0, y0) = I + 1
Picture1.PSet (x0, y0), vbWhite
For y = y0 - 1 To y0 + 1
For x = x0 - 1 To x0 + 1
If Picture1.Point(x, y) = vbBlack Then
Mk x, y
End If
Next x
Next y

End Function

[Debugger]

Заверни код в тег Code, когда его копируешь на форум. Так его легче читать.

Проверь, что у тебя не гигантская картинка. Если надо проверять большие картинки - используй нерекурсивный алгоритм.

Поставь ScaleMode в Pixel - по умолчанию всё меряется в твипах, и одну точку картинки проверяешь несколько сотен раз.

Поставь Autoredraw в True. Это даст программе возможность работать даже в свернутом виде. И немножко увеличит скорость.

Если цель - подсчитать, то необязательно закрашивать. Поменяй этот кусок:

Код: Выделить всё

Function Mk(x0, y0)
'On Error Resume Next
Dim x, y

If Picture1.Point(x0, y0) = vbWhite Then Exit Function

mask(x0, y0) = I + 1
Picture1.PSet (x0, y0), vbWhite
For y = y0 - 1 To y0 + 1
For x = x0 - 1 To x0 + 1
If Picture1.Point(x, y) = vbBlack Then
Mk x, y
End If
Next x
Next y
End Function

на этот:

Код: Выделить всё

Function Mk(x0, y0)
    Dim x, y
    If Picture1.Point(x0, y0) = vbWhite Then Exit Function
    mask(x0, y0) = I + 1
    For y = y0 - 1 To y0 + 1
        For x = x0 - 1 To x0 + 1
            If mask(x, y) = 0 Then
                Mk x, y
            End If
        Next x
    Next y
End Function

Суть в том, что мы проверяем mask, а не спрашиваем пиксели на каждый чих.

Поменяй

Код: Выделить всё

Picture1.Point(x0, y0)

на

Код: Выделить всё

GetPixel(Picture1.hdc, x0, y0)

не забыв вверху объявить функцию:

Код: Выделить всё

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

это - быстрая альтернатива Point.
Также, можно предварительно просканировать все точки в массив, а потом уже их проверять. Это даст огромный выигрыш в скорости.

Хотя, опять же - если у тебя очень большая картинка, то ты просто быстрее свалишься в Stack Overflow

[Qwertiy]

Объяви переменные по-нормальному с типами.

[Mikle]

Объяви переменные по-нормальному с типами.

Сейчас он объявит Dim i As Variant

[Sergey89]

Спасибо за подсказку! На небольших изображениях работает нормально, но когда ставлю с большим количеством объектов, снова начинает выдавать ошибку.

[Mikle]

Разверни рекурсию в цикл, объём стэка невелик. Хотя его, вроде как, можно увеличить параметром при компиляции.