Effacer tout les pixels qui ne sont pas de la couleur "x" dans une image bmp???? [Résolu]

Messages postés
35
Date d'inscription
vendredi 4 février 2005
Statut
Membre
Dernière intervention
3 août 2008
- - Dernière réponse : Gobillot
Messages postés
3140
Date d'inscription
vendredi 14 mai 2004
Statut
Membre
Dernière intervention
11 mars 2019
- 6 août 2005 à 15:55
bon voila je cherche une fonction, ou un code, qui me permette de ne conserver dans une image que les pixels qui sont d'une couleur précise (dans mon cas précis les pixels de couleur r:0 v:44 b:128), et que tout les pixels qui ne sont pas de cette couleur deviennent blanc par exemple, ou d'une autre couleur que je puisse choisir....

si vous savez aidez moi sivouplé!!!!!!!!!!!!!!!!!

ps: (si vous avez une fonction ou un code particulièrement rapide je suis trés trés preneur)
Afficher la suite 

4 réponses

Meilleure réponse
Messages postés
3140
Date d'inscription
vendredi 14 mai 2004
Statut
Membre
Dernière intervention
11 mars 2019
19
3
Merci
Option Explicit



Const BI_RGB = 0&

Const DIB_RGB_COLORS = 0



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 Long

biYPelsPerMeter As Long

biClrUsed As Long

biClrImportant As Long

End Type



Private Type RGBQUAD

rgbBlue As Byte

rgbGreen As Byte

rgbRed As Byte

rgbReserved As Byte

End Type



Private Type BITMAPINFO

bmiHeader As BITMAPINFOHEADER

bmiColors As RGBQUAD

End Type



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

Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc 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



Private Sub Command1_Click()

Dim bitmap As BITMAPINFO

Dim pixels() As Byte

Dim x As Integer

Dim y As Integer

Dim bw As Long

Dim bh As Long



bw = Picture1.ScaleWidth

bh = Picture1.ScaleHeight



With bitmap.bmiHeader

.biSize = 40

.biWidth = bw

.biHeight = -bh

.biPlanes = 1

.biBitCount = 32

.biCompression = BI_RGB

End With



ReDim pixels(1 To 4, 1 To bw, 1 To bh)

GetDIBits Picture1.hdc, Picture1.Image, 0, bh, pixels(1, 1, 1), bitmap, DIB_RGB_COLORS



For y = 1 To bh

For x = 1 To bw

If
pixels(1, x, y) 0 And pixels(2, x, y) 44 And pixels(3, x, y) = 128
Then


pixels(1, x, y) 255: pixels(2, x, y) 255: pixels(3, x, y) = 255

End If

Next

Next



SetDIBits Picture1.hdc, Picture1.Image, 0, bh, pixels(1, 1, 1), bitmap, DIB_RGB_COLORS

Picture1.Picture = Picture1.Image



End Sub



Daniel

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 222 internautes nous ont dit merci ce mois-ci

Messages postés
3172
Date d'inscription
dimanche 15 février 2004
Statut
Membre
Dernière intervention
9 avril 2017
25
3
Merci
Bonjour,



Voilà une autre méthode sans API mais qui marche certainnement moins bien.



Private Sub cmd1_Click()

pic1.ScaleMode = 3



Dim SearchColor As Long, RemplaceColor As Long


SearchColor = RGB(0, 44, 128)
RemplaceColor = RGB(255, 0, 0)



Dim Bh As Integer, Bw As Integer

Bh = pic1.ScaleHeight

Bw = pic1.ScaleWidth



Dim iX As Integer, iY As Integer

For iX = 0 To Bw

For iY = 0 To Bh

If pic1.Point(iX, iY) = SearchColor Then pic1.PSet (iX, iY), RemplaceColor

Next iY

Next iX



End Sub







ChRB
<hr size="2" width="100%">
Merci de cliquer sur "Réponse acceptée" si une réponse vous convient.

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 222 internautes nous ont dit merci ce mois-ci

Messages postés
35
Date d'inscription
vendredi 4 février 2005
Statut
Membre
Dernière intervention
3 août 2008
3
Merci
bon c'est nikel les deux codes font ce que je voulai j'ai juste du modifier ça:

Option Explicit

Const BI_RGB = 0&
Const DIB_RGB_COLORS = 0

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 Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type

Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type

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
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc 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

Private Sub Command1_Click()
Dim bitmap As BITMAPINFO
Dim pixels() As Byte
Dim x As Integer
Dim y As Integer
Dim bw As Long
Dim bh As Long

bw = Picture1.ScaleWidth
bh = Picture1.ScaleHeight

With bitmap.bmiHeader
.biSize = 40
.biWidth = bw
.biHeight = -bh
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
End With

ReDim pixels(1 To 4, 1 To bw, 1 To bh)
GetDIBits Picture1.hdc, Picture1.Image, 0, bh, pixels(1, 1, 1), bitmap, DIB_RGB_COLORS

For y = 1 To bh
For x = 1 To bw If pixels(1, x, y) 0 And pixels(2, x, y) 44 And pixels(3, x, y) = 128 Then
pixels(1, x, y) < > 255: pixels(2, x, y) < > 255: pixels(3, x, y) < > 255
End If
Next
Next

SetDIBits Picture1.hdc, Picture1.Image, 0, bh, pixels(1, 1, 1), bitmap, DIB_RGB_COLORS
Picture1.Picture = Picture1.Image

End Sub

et ça pour le second:

Private Sub cmd1_Click()
pic1.ScaleMode = 3

Dim SearchColor As Long, RemplaceColor As Long

SearchColor = RGB(0, 44, 128)
RemplaceColor = RGB(255, 0, 0)

Dim Bh As Integer, Bw As Integer
Bh = pic1.ScaleHeight
Bw = pic1.ScaleWidth

Dim iX As Integer, iY As Integer
For iX = 0 To Bw
For iY = 0 To Bh
If pic1.Point(iX, iY) <> SearchColor Then pic1.PSet (iX, iY), RemplaceColor
Next iY
Next iX

End Sub

merci à vous deux

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 222 internautes nous ont dit merci ce mois-ci

Messages postés
3140
Date d'inscription
vendredi 14 mai 2004
Statut
Membre
Dernière intervention
11 mars 2019
19
0
Merci
fait attention au And et OR



If pixels(1, x, y) <> 0 Or pixels(2, x, y) <> 44 Or pixels(3, x, y) <> 128 Then


on peut recevoir le résultat directement dans du Long, ce qui ferait
plus qu'un seul test donc plus rapide. mais je vais pas te perturber
plus.


Daniel