Поиск пикселя черного цвета в PictureBox (VB6)

@Rad0n · Регистрация: 12.01.2014

Студворк — интернет-сервис помощи студентам

Что мне в код добавить чтобы он еще искал черный пиксел и если он найден выдавалось сообщени!
Не пойму как и куда впихнуть проверки IF DIB_EGB_COLOR =0

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
Option Explicit
 
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 Double
biClrUsed As Double
End Type
 
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As Long
End Type
 
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
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
 
Const WW As Long = 1024, HH As Long = 768
 
Dim FPS As Long
Dim StrFPS As String
Dim bi32BitInfo As BITMAPINFO
Dim cBuf() As Long
 
Private Sub Form_Load()
Move Left, Top, Width - Screen.TwipsPerPixelX * (ScaleWidth - WW), Height - Screen.TwipsPerPixelY * (ScaleHeight - HH)
pic.Move 0, 0, WW, HH
Show
 
ReDim cBuf(WW - 1, HH - 1) As Long
With bi32BitInfo.bmiHeader
.biBitCount = 32
.biPlanes = 1
.biSize = Len(bi32BitInfo.bmiHeader)
.biWidth = WW
.biHeight = -HH
.biSizeImage = 4 * (WW * HH)
End With
 
While DoEvents
Render
FPS = FPS + 1
Wend
End Sub
 
Private Sub Render()
pic.Line (0, 0)-(WW, HH), 0, BF
pic.CurrentX = 8
pic.CurrentY = 8
pic.Print StrFPS;
GetDIBits hDC, pic.Image.Handle, 0, HH, cBuf(0, 0), bi32BitInfo, 0
SetDIBitsToDevice hDC, 0, 0, WW, HH, 0, 0, 0, HH, cBuf(0, 0), bi32BitInfo, 0
End Sub
 
Private Sub Timer1_Timer()
StrFPS = FPS
FPS = 0
End Sub

@Otwet · 14.05.2014, 15:03

Создай на форме 2 кнопки и picture-бокс

код:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Private Sub Command1_Click()
picture1.PSet (1,1)
end sub
 
Private Sub Command2_Click()
 
Dim xpos As Long
Dim ypos As Long
 
For xpos = 0 To Picture1.Width - 1
   For ypos = 0 To Picture1.Height - 1
     If GetPixel(Picture1.hdc, xpos, ypos) = 0 Then
           msgbox "Привет, {Цензура}"
     End If
   Next
Next
 
End Sub

Жмешь 1 кнопку и он рисует чер. точку
Жмешь 2 кнопку и он ищет чер.цвет

Добавлено через 5 минут
Апи:

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

@The trick · 14.05.2014, 15:59

Otwet, GetPixel для разового пиксела, для получения всех пикселов им пользоваться нехорошо, к тому же есть тот же метод Point, без всяких апи.Rad0n, ты вообще для чего этот код привел? Какой прикол бездумно копировать код не по назначению?

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
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 Any, ByVal wUsage As Long) As Long
 
Private Sub Form_Load()
    Dim pix()       As Long
    Dim bi(11)      As Long
    Dim pic         As IPicture
    Dim s           As Long
    Dim x           As Long
    Dim y           As Long
    
    Set pic = Image1.Picture
 
    bi(0) = 40
    GetDIBits Me.hdc, pic.Handle, 0, ScaleY(pic.Height, vbHimetric, vbPixels), ByVal 0&, bi(0), 0
    bi(4) = 0: bi(3) = &H200001
 
    ReDim pix(bi(1) - 1, bi(2) - 1)
 
    GetDIBits Me.hdc, pic.Handle, 0, bi(2), pix(0, 0), bi(0), 0
    
    For y = bi(2) - 1 To 0 Step -1: For x = 0 To bi(1) - 1
        If pix(x, y) = vbBlack Then Stop
    Next: Next
 
End Sub

@Rad0n · 14.05.2014, 16:03 **[ТС]**

ВЫХОДИТ ОШИБКА SUBSCRIPT OUT OF RANGE!
ReDim pix(bi(1) - 1, bi(2) - 1) - В ЭТОЙ СТРОЧКЕ
Сделай для Picturebox пожалуйста
Добавлено через 2 минуты

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
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 Any, ByVal wUsage As Long) As Long
 
Private Sub Form_Load()
    Dim pix()       As Long
    Dim bi(11)      As Long
    Dim pic         As IPicture
    Dim s           As Long
    Dim x           As Long
    Dim y           As Long
    
    Set pic = Image1.Picture
 
    bi(0) = 40
    GetDIBits Me.hDC, pic.Handle, 0, ScaleY(pic.Height, vbHimetric, vbPixels), ByVal 0&, bi(0), 0
    bi(4) = 0: bi(3) = &H200001
 
    ReDim pix(bi(1) - 1, bi(2) - 1)
 
    GetDIBits Me.hDC, pic.Handle, 0, bi(2), pix(0, 0), bi(0), 0
    
    For y = bi(2) - 1 To 0 Step -1: For x = 0 To bi(1) - 1
        If pix(x, y) = vbBlack Then Stop
    Next: Next
 
End Sub

А как мне следать для Picture1.Hdc? Мне нужно в PIcturebox искать подредактируй пожалуйста! ДРуг!

@The trick · 14.05.2014, 16:06

Сообщение от Rad0n

А как мне следать для Picture1.Hdc? Мне нужно в PIcturebox искать подредактируй пожалуйста! ДРуг!

Ну я могу тебя направить читать MSDN (GDI). HDC - контекст, это не картинка. Картинка либо Image, либо Picture.

@Rad0n · 14.05.2014, 16:10 **[ТС]**

Ну у меня картинка не в Image1 а в Picturebox

@The trick · 14.05.2014, 16:12

Rad0n,

. Подумай немного головой это элементарно. Твою задачу я решил на 99.(9)%.

@Rad0n · 14.05.2014, 16:27 **[ТС]**

ЧТо то выходит ошибка диапазона в свойствах Picturebox указал пиксель
Subscript Out OF Range

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
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 Any, ByVal wUsage As Long) As Long
 
Private Sub Form_Load()
    Dim pix()       As Long
    Dim bi(11)      As Long
    Dim pic         As IPicture
    Dim s           As Long
    Dim x           As Long
    Dim y           As Long
    
    Set pic = Picture1.Picture
 
    bi(0) = 40
    GetDIBits Me.hDC, pic.Handle, 0, ScaleY(pic.Height, vbHimetric, vbPixels), ByVal 0&, bi(0), 0
    bi(4) = 0: bi(3) = &H200001
 
    ReDim pix(bi(1) - 1, bi(2) - 1)
 
    GetDIBits Me.hDC, pic.Handle, 0, bi(2), pix(0, 0), bi(0), 0
    
    For y = bi(2) - 1 To 0 Step -1: For x = 0 To bi(1) - 1
        If pix(x, y) = vbBlack Then Text1.Text = "OK"
        
    Next: Next
 
End Sub

Добавлено через 10 минут
The TRICK!
СПАСИБО ТЕБЕ БОЛЬШОЕ! ТЫ единственный Кто смог помочь а то другие строчку дают кода а ты потом думай что с ним делать!
А ускорить процесс поиска никак нельзя ?

@The trick · 14.05.2014, 16:30

Сообщение от Rad0n

А ускорить процесс поиска никак нельзя ?

Можно. Скомпилируй в Native-code со всеми опциями оптимизации.
Еще можно ускорить применяя ассемблерные вставки.
Еще можно ускорить применяя SIMD инструкции.
Еще можно ускорить просчитывая на видеокарте (хотя не уверен в данном случае).

@Rad0n · 14.05.2014, 17:20 **[ТС]**

Спасибо большое! А эта функция Быстрее работает чем GetPIXEL? А то чет особо не заметил GetPIxel зависал это хоть не зависает

Добавлено через 3 минуты
А если в таймер пихну не зависнет ?
Мне таймером надо(

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Dim pix()       As Long
    Dim bi(11)      As Long
    Dim pic         As IPicture
    Dim s           As Long
    Dim x           As Long
    Dim y           As Long
    
    Set pic = Picture1.Image
 
    bi(0) = 40
    GetDIBits Me.hDC, pic.Handle, 0, ScaleY(pic.Height, vbHimetric, vbPixels), ByVal 0&, bi(0), 0
    bi(4) = 0: bi(3) = &H200001
 
    ReDim pix(bi(1) - 1, bi(2) - 1)
 
    GetDIBits Me.hDC, pic.Handle, 0, bi(2), pix(0, 0), bi(0), 0
    
    For y = bi(2) - 1 To 0 Step -1: For x = 0 To bi(1) - 1
        If pix(x, y) = RGB(255, 255, 255) Then Text1.Text = "OK"
        
    Next: Next

Добавлено через 24 минуты
И еще почему не ищет в RGB ?

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Dim pix()       As Long
    Dim bi(11)      As Long
    Dim pic         As IPicture
    Dim s           As Long
    Dim x           As Long
    Dim y           As Long
    
    Set pic = Picture1.Image
 
    bi(0) = 40
    GetDIBits Me.hDC, pic.Handle, 0, ScaleY(pic.Height, vbHimetric, vbPixels), ByVal 0&, bi(0), 0
    bi(4) = 0: bi(3) = &H200001
 
    ReDim pix(bi(1) - 1, bi(2) - 1)
 
    GetDIBits Me.hDC, pic.Handle, 0, bi(2), pix(0, 0), bi(0), 0
    
    For y = bi(2) - 1 To 0 Step -1: For x = 0 To bi(1) - 1
        If pix(x, y) = RGB(237, 28, 36) Then Text1.Text = "OK"
        
    Next: Next
End Sub

Такой цвет не находи хоть я проверил все правильно цвет есть когда пишу RGB(255,255,255) то белый находит и черный другие цвета нет ( странно

@The trick · 14.05.2014, 17:24

Сообщение от Rad0n

А если в таймер пихну не зависнет ?

Нет.

Сообщение от Rad0n

А эта функция Быстрее работает чем GetPIXEL?

В сотни раз быстрее.

Сообщение от Rad0n

И еще почему не ищет в RGB ?

Потому что в GDI идет RGB, в VB задается как BGR (красный и синий каналы поменяй местами)

@Rad0n · 14.05.2014, 21:01 **[ТС]**

ИЩЕТ ТОЛЬКО СТАНДАРТНЫЕ ЦВЕТА RGB(255,255,255) а например это уже не находит почему ? Самому богу только наверное известно

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
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 Any, ByVal wUsage As Long) As Long
     
    Private Sub Form_Load()
        Dim pix()       As Long
        Dim bi(11)      As Long
        Dim pic         As IPicture
        Dim s           As Long
        Dim x           As Long
        Dim y           As Long
     
        Set pic = Image1.Picture
     
        bi(0) = 40
        GetDIBits Me.hdc, pic.Handle, 0, ScaleY(pic.Height, vbHimetric, vbPixels), ByVal 0&, bi(0), 0
        bi(4) = 0: bi(3) = &H200001
     
        ReDim pix(bi(1) - 1, bi(2) - 1)
     
        GetDIBits Me.hdc, pic.Handle, 0, bi(2), pix(0, 0), bi(0), 0
     
        For y = bi(2) - 1 To 0 Step -1: For x = 0 To bi(1) - 1
            If pix(x, y) = RGB(22,21,27) --- ТАКОЙ ЦВЕТ УЖЕ НЕ МОЖЕТ НАЙТИ!ДЛЯ ОСОБО УМНЫХ ПИКСЕЛЬ ЭТОГО ЦВЕТА БЕРУ ПРЯМО С КАРТИНКИ!!ТАК ЧТО НЕ ГОВОРИТЬ А ТЫ УВЕРЕН ЧТО ТАКОЙ ПИКСЕЛЬ ТАМ ЕСТЬ!? 
        Next: Next
     
    End Sub

ВОТ КАРТИНКА ГДЕ ЕСТЬ ЭТОТ ПИКСЕЛЬ http://rghost.ru/55157529 можете сами попробовать не может в чем проблема не понятно

@The trick · 14.05.2014, 21:13

Сообщение от Rad0n

ТАКОЙ ЦВЕТ УЖЕ НЕ МОЖЕТ НАЙТИ!ДЛЯ ОСОБО УМНЫХ ПИКСЕЛЬ ЭТОГО ЦВЕТА БЕРУ ПРЯМО С КАРТИНКИ!!ТАК ЧТО НЕ ГОВОРИТЬ А ТЫ УВЕРЕН ЧТО ТАКОЙ ПИКСЕЛЬ ТАМ ЕСТЬ!?

Сообщение от The trick

Потому что в GDI идет RGB, в VB задается как BGR (красный и синий каналы поменяй местами)

@Rad0n · 14.05.2014, 21:36 **[ТС]**

Вот ТАк ? Братан ? Ошибку выдает Sub Function не определены
Вместо If pix(x, y) = RGB(22, 21, 27) Then Text1.Text = "OK"
ТАК ?
If pix(x, y) = BGR(22, 21, 27) Then Text1.Text = "OK"

@The trick · 14.05.2014, 21:42

Rad0n,

.

Visual Basic
1
RGB(27, 21, 22)

@Rad0n · 14.05.2014, 21:58 **[ТС]**

Я уже понял ну ты ЖЕ НЕ НАПИСАЛ ЧТО НАДО МЕНЯ ЗНАЧЕНИЯ А НЕ RGB вот и гадай А откуда ты это все знаешь бро ? Скинь url откуда ты вычитал все это ) Что передается не RGB а BGR Я об ничего слава богу ты мне помог а то бы всю жизнь возился )
А cyber форуме только кусками дают только нервы одни xD то что и в гугле можно нарыть )

Добавлено через 11 минут
И откуда ты все это знаешь спасибо братан очень помог а то я уже думал ничего не выйдет собирался забивать(

А если я захочу получить с активного ОКНА ПИКСЕЛЬ ?
GetDIBits Me.hDC, pic.Handle, 0, bi(2), pix(0, 0), bi(0), 0

@The trick · 14.05.2014, 22:10

Сообщение от Rad0n

Я уже понял ну ты ЖЕ НЕ НАПИСАЛ ЧТО НАДО МЕНЯ ЗНАЧЕНИЯ А НЕ RGB вот и гадай А откуда ты это все знаешь бро ? Скинь url откуда ты вычитал все это ) Что передается не RGB а BGR Я об ничего слава богу ты мне помог а то бы всю жизнь возился )
А cyber форуме только кусками дают только нервы одни xD то что и в гугле можно нарыть ) Добавлено через 11 минут
И откуда ты все это знаешь спасибо братан очень помог а то я уже думал ничего не выйдет собирался забивать(

Эти знания получены не за 1 день, также по крупицам на форумах. Хотя основные навыки программирования графики я узнал из книги Фень Юань - "Программирование графики для Windows"

Сообщение от Rad0n

А если я захочу получить с активного ОКНА ПИКСЕЛЬ ?
GetDIBits Me.hDC, pic.Handle, 0, bi(2), pix(0, 0), bi(0), 0

Для получения 1-го пикселя можно использовать GetPixel (Point), для получения из произвольного окна (любого приложения), сначала получать его хендл, получать контекст устройства данного окна, получать картинку выбранную в этом контексте, оттуда получать биты рисунка.

@Rad0n · 15.05.2014, 14:52 **[ТС]**

А как мне например искать только первый цветовой канал ? в RGB(30,35,51)
Мне например нужно проверить только 30 а вторые два неважно как это сделать ? Это возможно ?
Например мне надо так If R=30 or G >35 or B <51 then ? Думаю понял что я хочу

Новые блоги и статьи Все статьи Все блоги /
SDL3 для Web (WebAssembly): Обработчик клика мыши в браузере ПК и касания экрана в браузере на мобильном устройстве 8Observer8 02.02.2026 Содержание блога Для начала пошагово создадим рабочий пример для подготовки к экспериментам в браузере ПК и в браузере мобильного устройства. Потом напишем обработчик клика мыши и обработчик. . .	Философия технологии iceja 01.02.2026 На мой взгляд у человека в технических проектах остается роль генерального директора. Все остальное нейронки делают уже лучше человека. Они не могут нести предпринимательские риски, не могут. . .	SDL3 для Web (WebAssembly): Вывод текста со шрифтом TTF с помощью SDL3_ttf 8Observer8 01.02.2026 Содержание блога В этой пошаговой инструкции создадим с нуля веб-приложение, которое выводит текст в окне браузера. Запустим на Android на локальном сервере. Загрузим Release на бесплатный. . .	SDL3 для Web (WebAssembly): Сборка C/C++ проекта из консоли 8Observer8 30.01.2026 Содержание блога Если вы откроете примеры для начинающих на официальном репозитории SDL3 в папке: examples, то вы увидите, что все примеры используют следующие четыре обязательные функции, а. . .
SDL3 для Web (WebAssembly): Установка Emscripten SDK (emsdk) и CMake для сборки C и C++ приложений в Wasm 8Observer8 30.01.2026 Содержание блога Для того чтобы скачать Emscripten SDK (emsdk) необходимо сначало скачать и уставить Git: Install for Windows. Следуйте стандартной процедуре установки Git через установщик. . . .	SDL3 для Android: Подключение Box2D v3, физика и отрисовка коллайдеров 8Observer8 29.01.2026 Содержание блога Box2D - это библиотека для 2D физики для анимаций и игр. С её помощью можно определять были ли коллизии между конкретными объектами. Версия v3 была полностью переписана на Си, в. . .	Инструменты COM: Сохранение данный из VARIANT в файл и загрузка из файла в VARIANT bedvit 28.01.2026 Сохранение базовых типов COM и массивов (одномерных или двухмерных) любой вложенности (деревья) в файл, с возможностью выбора алгоритмов сжатия и шифрования. Часть библиотеки BedvitCOM Использованы. . .	SDL3 для Android: Загрузка PNG с альфа-каналом с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 28.01.2026 Содержание блога SDL3 имеет собственные средства для загрузки и отображения PNG-файлов с альфа-каналом и базовой работы с ними. В этой инструкции используется функция SDL_LoadPNG(), которая. . .

@Rad0n -18 / 3 / 0 Регистрация: 12.01.2014 Сообщений: 210
	14.05.2014, 16:10 [ТС]
	Ну у меня картинка не в Image1 а в Picturebox 0

@The trick Модератор 10048 / 3894 / 883 Регистрация: 22.02.2013 Сообщений: 5,847 Записей в блоге: 79
	14.05.2014, 16:12
	Rad0n, . Подумай немного головой это элементарно. Твою задачу я решил на 99.(9)%. 0

@Rad0n -18 / 3 / 0 Регистрация: 12.01.2014 Сообщений: 210
	14.05.2014, 21:36 [ТС]
	Вот ТАк ? Братан ? Ошибку выдает Sub Function не определены Вместо If pix(x, y) = RGB(22, 21, 27) Then Text1.Text = "OK" ТАК ? If pix(x, y) = BGR(22, 21, 27) Then Text1.Text = "OK" 0

@Rad0n -18 / 3 / 0 Регистрация: 12.01.2014 Сообщений: 210
	14.05.2014, 21:58 [ТС]
	Я уже понял ну ты ЖЕ НЕ НАПИСАЛ ЧТО НАДО МЕНЯ ЗНАЧЕНИЯ А НЕ RGB вот и гадай А откуда ты это все знаешь бро ? Скинь url откуда ты вычитал все это ) Что передается не RGB а BGR Я об ничего слава богу ты мне помог а то бы всю жизнь возился ) А cyber форуме только кусками дают только нервы одни xD то что и в гугле можно нарыть ) Добавлено через 11 минут И откуда ты все это знаешь спасибо братан очень помог а то я уже думал ничего не выйдет собирался забивать( А если я захочу получить с активного ОКНА ПИКСЕЛЬ ? GetDIBits Me.hDC, pic.Handle, 0, bi(2), pix(0, 0), bi(0), 0 0

@Rad0n -18 / 3 / 0 Регистрация: 12.01.2014 Сообщений: 210
	15.05.2014, 14:52 [ТС]
	А как мне например искать только первый цветовой канал ? в RGB(30,35,51) Мне например нужно проверить только 30 а вторые два неважно как это сделать ? Это возможно ? Например мне надо так If R=30 or G >35 or B <51 then ? Думаю понял что я хочу 0

Поиск пикселя черного цвета в PictureBox (VB6)

Решение