Поиск пикселя черного цвета в 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 для Desktop (MinGW): Создаём пустое окно с нуля для 2D-графики на SDL3, Си и C++ 8Observer8 10.03.2026 Содержание блога Финальные проекты на Си и на C++: hello-sdl3-c. zip hello-sdl3-cpp. zip Результат:	Установка CMake и MinGW 13.1 для сборки С и C++ приложений из консоли и из Qt Creator в EXE 8Observer8 10.03.2026 Содержание блога MinGW - это коллекция инструментов для сборки приложений в EXE. CMake - это система сборки приложений. Здесь описаны базовые шаги для старта программирования с помощью CMake и. . .	Как дизайн сайта влияет на конверсию: 7 решений, которые реально повышают заявки Neotwalker 08.03.2026 Многие до сих пор воспринимают дизайн сайта как “красивую оболочку”. На практике всё иначе: дизайн напрямую влияет на то, оставит человек заявку или уйдёт через несколько секунд. Даже если у вас. . .	Модульная разработка через nuget packages DevAlt 07.03.2026 Сложившийся в . Net-среде способ разработки чаще всего предполагает монорепозиторий в котором находятся все исходники. При создании нового решения, мы просто добавляем нужные проекты и имеем. . .
Модульный подход на примере F# DevAlt 06.03.2026 В блоге дяди Боба наткнулся на такое определение: В этой книге («Подход, основанный на вариантах использования») Ивар утверждает, что архитектура программного обеспечения — это структуры,. . .	Управление камерой с помощью скрипта OrbitControls.js на Three.js: Вращение, зум и панорамирование 8Observer8 05.03.2026 Содержание блога Финальная демка в браузере работает на Desktop и мобильных браузерах. Итоговый код: orbit-controls-threejs-js. zip. Сканируйте QR-код на мобильном. Вращайте камеру одним пальцем,. . .	SDL3 для Web (WebAssembly): Синхронизация спрайтов SDL3 и тел Box2D 8Observer8 04.03.2026 Содержание блога Финальная демка в браузере. Итоговый код: finish-sync-physics-sprites-sdl3-c. zip На первой гифке отладочные линии отключены, а на второй включены:. . .	SDL3 для Web (WebAssembly): Идентификация объектов на Box2D v3 - использование userData и событий коллизий 8Observer8 02.03.2026 Содержание блога Финальная демка в браузере. Итоговый код: finish-collision-events-sdl3-c. zip Сканируйте QR-код на мобильном и вы увидите, что появится джойстик для управления главным героем. . . .

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

@The trick Модератор 10057 / 3902 / 884 Регистрация: 22.02.2013 Сообщений: 5,853 Записей в блоге: 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)

Решение