Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Développement Développement Visual Basic Lire les pixels d'une image

Lire les pixels d'une image

11 réponses
Avatar
Yves
Bonjour,

Je voudrais avoir du code Vb6 pour pouvoir ouvrir une image (bmp,jpg et
autre) et lire chaque pixels


--
Merci pour les réponses
--
Yves
Signaler un problème avec ce contenu

10 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
1 2
Avatar
ng
Salut,

Tu peux le faire en la chargeant ds une picturebox avec la méthode Point().
Sinon il faudra utiliser les APIs GDI (notamment GetPixel()).

Bonjour,

Je voudrais avoir du code Vb6 pour pouvoir ouvrir une image (bmp,jpg et
autre) et lire chaque pixels





--
Nicolas G.
FAQ VB : http://faq.vb.free.fr
API Guide : http://www.allapi.net
Google Groups : http://groups.google.fr/
MZ-Tools : http://www.mztools.com/
Avatar
Zoury
Salut Yves ! :O)

Je voudrais avoir du code Vb6 pour pouvoir ouvrir une image (bmp,jpg et
autre) et lire chaque pixels



Si tu as besoin de vitesse , opte pour l'API GetDIBits(), voici un exemple.
http://www.mentalis.org/apilist/GetDIBits.shtml

Si tu n'es pas familier avec GDI, je te recommende fortement les tutoriels
se trouvant sur cette page (en anglais malheureusement) :
http://edais.mvps.org/Tutorials/index.html


Voici l'ordre logique à suivre pour ne pas trop te perdre :

1. Basic introduction to graphics programming
2. Using DCs
3. Using DDBs
4. Using DIBs


Ce même site offre tout pleins d'exemples d'utilisation de GDI, amuse toi.
:O)

--
Cordialement
Yanick
MVP pour Visual Basic
Avatar
LE TROLL
Je rappelle que sur un forum FR l'anglais est strictement
interdit, seul le latin, le grec et ce qui en découle est
accepté :o)
-----------------



"Zoury" <yanick_lefebvre at hotmail dot com> a écrit dans le
message de news:
Salut Yves ! :O)

Je voudrais avoir du code Vb6 pour pouvoir ouvrir une
image (bmp,jpg et
autre) et lire chaque pixels



Si tu as besoin de vitesse , opte pour l'API GetDIBits(),
voici un exemple.
http://www.mentalis.org/apilist/GetDIBits.shtml

Si tu n'es pas familier avec GDI, je te recommende
fortement les tutoriels
se trouvant sur cette page (en anglais malheureusement) :
http://edais.mvps.org/Tutorials/index.html


Voici l'ordre logique à suivre pour ne pas trop te perdre
:

1. Basic introduction to graphics programming
2. Using DCs
3. Using DDBs
4. Using DIBs


Ce même site offre tout pleins d'exemples d'utilisation de
GDI, amuse toi.
:O)

--
Cordialement
Yanick
MVP pour Visual Basic




Avatar
louise desbiens
Bonjour,

Merci pour vos réponses

Mais je veus pouvoir savoir comment les images sont coder.
l'ouvrir en mode texte et pouvoir vérifier chaque pixel sans le mettre dans
un objet

ex:
ouvre le fichier graphique (jpg, bmp)
avoir sa grandeur (entete Hauteur et largeur)
compter chaque pixel de tel couleur
Noir 250 pixels
Bleu 400 pixels

J'espère que je me suis fait comprendre

merci pour votre aide

Yves

Je veus pouvoir compter chaque pixels de couleur d'un image



"Yves" a écrit dans le message de news:

Bonjour,

Je voudrais avoir du code Vb6 pour pouvoir ouvrir une image (bmp,jpg et
autre) et lire chaque pixels


--
Merci pour les réponses
--
Yves




Avatar
Driss HANIB
bonjour louise

tu devrais regarder sur le net plein de pages qui contiennet la structure
des fichiers
exemple pour BMP

http://www.google.fr/search?sourceid=navclient&hl=fr&ie=UTF-8&rls=GGLD,GGLD:2004-45,GGLD:fr&q=structure+BMP

je sais qu'il existe des sites mais je ne me rappelle pas l'adresse

je vais regarder cela..

Driss

"louise desbiens" a écrit dans le message de
news:QO_be.8148$
Bonjour,

Merci pour vos réponses

Mais je veus pouvoir savoir comment les images sont coder.
l'ouvrir en mode texte et pouvoir vérifier chaque pixel sans le mettre


dans
un objet

ex:
ouvre le fichier graphique (jpg, bmp)
avoir sa grandeur (entete Hauteur et largeur)
compter chaque pixel de tel couleur
Noir 250 pixels
Bleu 400 pixels

J'espère que je me suis fait comprendre

merci pour votre aide

Yves

Je veus pouvoir compter chaque pixels de couleur d'un image



"Yves" a écrit dans le message de news:

> Bonjour,
>
> Je voudrais avoir du code Vb6 pour pouvoir ouvrir une image (bmp,jpg et
> autre) et lire chaque pixels
>
>
> --
> Merci pour les réponses
> --
> Yves
>
>




Avatar
Driss HANIB
voici comme convenu un site qui te permet de connaitre la structure de très
nombreux fichiers

http://www.wotsit.org/

Bon courage

Driss

"louise desbiens" a écrit dans le message de
news:QO_be.8148$
Bonjour,

Merci pour vos réponses

Mais je veus pouvoir savoir comment les images sont coder.
l'ouvrir en mode texte et pouvoir vérifier chaque pixel sans le mettre


dans
un objet

ex:
ouvre le fichier graphique (jpg, bmp)
avoir sa grandeur (entete Hauteur et largeur)
compter chaque pixel de tel couleur
Noir 250 pixels
Bleu 400 pixels

J'espère que je me suis fait comprendre

merci pour votre aide

Yves

Je veus pouvoir compter chaque pixels de couleur d'un image



"Yves" a écrit dans le message de news:

> Bonjour,
>
> Je voudrais avoir du code Vb6 pour pouvoir ouvrir une image (bmp,jpg et
> autre) et lire chaque pixels
>
>
> --
> Merci pour les réponses
> --
> Yves
>
>




Avatar
Yves
Merci beaucoup pour vos réponse

J'aimerais avoir du code en vb6 pour ouvrir un bmp et jpg


--
--
Cordialement
Yves






"Driss HANIB" a écrit dans le message de
news:
voici comme convenu un site qui te permet de connaitre la structure de


très
nombreux fichiers

http://www.wotsit.org/

Bon courage

Driss

"louise desbiens" a écrit dans le message


de
news:QO_be.8148$
> Bonjour,
>
> Merci pour vos réponses
>
> Mais je veus pouvoir savoir comment les images sont coder.
> l'ouvrir en mode texte et pouvoir vérifier chaque pixel sans le mettre
dans
> un objet
>
> ex:
> ouvre le fichier graphique (jpg, bmp)
> avoir sa grandeur (entete Hauteur et largeur)
> compter chaque pixel de tel couleur
> Noir 250 pixels
> Bleu 400 pixels
>
> J'espère que je me suis fait comprendre
>
> merci pour votre aide
>
> Yves
>
> Je veus pouvoir compter chaque pixels de couleur d'un image
>
>
>
> "Yves" a écrit dans le message de news:
>
> > Bonjour,
> >
> > Je voudrais avoir du code Vb6 pour pouvoir ouvrir une image (bmp,jpg


et
> > autre) et lire chaque pixels
> >
> >
> > --
> > Merci pour les réponses
> > --
> > Yves
> >
> >
>
>




Avatar
Driss HANIB
sur planet-source-code ou vbfrance il y a des classes qui traites ces
fichiers..
Driss
"Yves" a écrit dans le message de
news:
Merci beaucoup pour vos réponse

J'aimerais avoir du code en vb6 pour ouvrir un bmp et jpg


--
--
Cordialement
Yves






"Driss HANIB" a écrit dans le message de
news:
> voici comme convenu un site qui te permet de connaitre la structure de
très
> nombreux fichiers
>
> http://www.wotsit.org/
>
> Bon courage
>
> Driss
>
> "louise desbiens" a écrit dans le message
de
> news:QO_be.8148$
> > Bonjour,
> >
> > Merci pour vos réponses
> >
> > Mais je veus pouvoir savoir comment les images sont coder.
> > l'ouvrir en mode texte et pouvoir vérifier chaque pixel sans le mettre
> dans
> > un objet
> >
> > ex:
> > ouvre le fichier graphique (jpg, bmp)
> > avoir sa grandeur (entete Hauteur et largeur)
> > compter chaque pixel de tel couleur
> > Noir 250 pixels
> > Bleu 400 pixels
> >
> > J'espère que je me suis fait comprendre
> >
> > merci pour votre aide
> >
> > Yves
> >
> > Je veus pouvoir compter chaque pixels de couleur d'un image
> >
> >
> >
> > "Yves" a écrit dans le message de news:
> >
> > > Bonjour,
> > >
> > > Je voudrais avoir du code Vb6 pour pouvoir ouvrir une image (bmp,jpg
et
> > > autre) et lire chaque pixels
> > >
> > >
> > > --
> > > Merci pour les réponses
> > > --
> > > Yves
> > >
> > >
> >
> >
>
>




Avatar
Zoury
Salut Yves! :O)

Voici quelque chose qui pourrait te donner un bon coup de pouce. Le code
fonctionne seulement avec des bitmaps 24bits. Présentement il t'imprime les
couleurs du bitmap en lisant pixels par pixels de gauche à droite et de haut
en bas. Il ne te reste plus qu'à compter combien de fois les couleurs
reviennent.

ex :
'***
' Module
Option Explicit

Private Sub Main()

Call PrintBMPColorsCount("c:image.bmp")

End Sub

Private Sub PrintBMPColorsCount(ByRef sFileName As String)

Dim o As DC
Dim i1 As Long
Dim i2 As Long
Dim lColor As Long
Dim col As Collection

Set o = New DC
Call o.LoadBMP(sFileName)

Debug.Print "Info sur le bitmap """ & sFileName & """"
Debug.Print "taille " & o.Width & " x " & o.Height

For i1 = 0 To o.Height - 1
For i2 = 0 To o.Scanline - 1 Step 4
' on imprime la couleur les pixels un après l'autre (lecture de
gauche à droite, de haut en bas)
Debug.Print Hex$(RGB(o.ImgData(i2, i1), o.ImgData(i2 + 1, i1),
o.ImgData(i2 + 2, i1)))
Next i2
Next i1

End Sub
'***

tu auras besoin de la classe suivante (attention au retour à la ligne):
'***
'****************************************
' Nom de classe : DC
' Source original : Mike D Sutton
' Adapté par : Yanick Lefebvre
'****************************************
Option Explicit

Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As
Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long)
As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal
hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd 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 BITMAPINFOHEADER, ByVal wUsage As Long) As Long

'Information relative à l'entête du bitmap
Private Type BITMAPINFOHEADER '40 bytes
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

'Information relative à l'entête du fichier
Private Type BITMAPFILEHEADER '14 bytes
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type

Private m_hDC As Long 'Référence au DC
Private m_hDIB As Long 'Référence as DIB
Private m_iWidth As Integer 'Largeur du DIB
Private m_iHeight As Integer 'Hauteur du DIB
Private m_hPen As Long 'Référence au crayon
Private m_hBrush As Long 'Référence à la pinceau
Private m_hFont As Long 'Référence à la police de charactère
Private m_byImgData() As Byte 'Donnée de l'image
Private m_lScanLine As Long 'Longueur d'une ligne en pixel

Private hOldDIB As Long 'Ancienne référence au DIB
Private hOldPen As Long 'Ancienne référence au crayon
Private hOldBrush As Long 'Ancienne référence a la pinceau
Private hOldFont As Long 'Ancienne référence à la police de charactère

Private Const bmMagicCookie = &H4D42 'Entête de Bitmap "BM"


Private Sub Class_Terminate()

On Error GoTo ErrHandler

KillDIB 'Détruit le DIB
KillPen 'Détruit le crayon
KillBrush 'Détruit la pinceau
KillFont 'Détruit la police

Terminate:
Exit Sub

ErrHandler:
GoTo Terminate
End Sub

Public Property Get Height() As Integer
Height = m_iHeight
End Property

Public Property Get ImgData(ByRef i1 As Long, ByRef i2 As Long) As Byte
ImgData = m_byImgData(i1, i2)
End Property

Public Property Get Scanline() As Long
Scanline = m_lScanLine
End Property

Private Sub KillBrush(Optional ByRef lErrNum As Long)

On Error GoTo ErrHandler

'Vérifie si la brosse existe
If m_hBrush <> 0 Then

'Change la brosse sélectionnée
SelectObject m_hDC, hOldBrush

'Supprime la brosse
DeleteObject m_hBrush

'Efface la référence à la brosse
m_hBrush = 0
End If

Terminate:
Exit Sub

ErrHandler:
lErrNum = Err.Number
GoTo Terminate
End Sub

Public Sub KillDIB(Optional ByRef lErrNum As Long)

On Error GoTo ErrHandler

'Vérifie si notre DIB existe
If m_hDC <> 0 Then

'Déselectionne le DIB sélectionné
SelectObject m_hDC, hOldDIB

'Détruit le DIB
DeleteObject m_hDC

'Détruit le DC
DeleteDC m_hDC

'Efface les dimensions
m_iWidth = 0
m_iHeight = 0

'Efface la référence au DC
m_hDC = 0
End If

Terminate:
Exit Sub

ErrHandler:
lErrNum = Err.Number
GoTo Terminate
End Sub

Public Sub KillFont(Optional ByRef lErrNum As Long)

On Error GoTo ErrHandler

'Vérifie si la police existe
If m_hFont <> 0 Then

'Change la police sélectionnée
SelectObject m_hDC, hOldFont

'Supprime la police
DeleteObject m_hFont

'Efface la référence à la police
m_hFont = 0
End If

Terminate:
Exit Sub

ErrHandler:
lErrNum = Err.Number
GoTo Terminate
End Sub

Private Sub KillPen(Optional ByRef lErrNum As Long)

On Error GoTo ErrHandler

'Vérifie si le crayon existe
If m_hPen <> 0 Then

'Change le crayon sélectionné
SelectObject m_hDC, hOldPen

'Supprime le crayon
DeleteObject m_hPen

'Efface la référence au crayon
m_hPen = 0
End If

Terminate:
Exit Sub

ErrHandler:
lErrNum = Err.Number
GoTo Terminate
End Sub

Public Function LoadBMP(ByRef sFile As String, _
Optional ByRef lErrNum As Long) As Boolean

Dim FileHead As BITMAPFILEHEADER
Dim InfoHead As BITMAPINFOHEADER
Dim hFileNum As Long 'Référence au fichier
Dim hDesk As Long
Dim hDeskDC As Long

On Error GoTo ErrHandler

'Vérifie si le fichier existe
If LenB(Dir(sFile)) = 0 Then
MsgBox "Fichier inexistant", vbCritical, App.Title
GoTo Terminate
End If

'Détruit l'image courante
If m_hDC <> 0 Then
KillDIB
End If

'Obtient une nouvelle référence de fichier
hFileNum = FreeFile

'Ouvre le fichier
Open sFile For Binary As #hFileNum
'Lit l'entête du fichier
Get #hFileNum, , FileHead 'File header

'Vérifie l'entête pour être sure que c'est un bitmap
If FileHead.bfType <> bmMagicCookie Then
MsgBox "Ce fichier n'est un bitmap valide", vbCritical,
App.Title

'Ferme le fichier et quitte la fonction
Close #hFileNum
GoTo Terminate
End If

Get #hFileNum, , InfoHead 'Lit l'entête de l'image

With InfoHead
'Vérifie si l'image est une image de format 24bit
If .biBitCount <> 24 Or _
.biCompression <> 0 Or _
.biPlanes <> 1 Or _
.biHeight < 1 Or _
.biWidth < 1 Then

'Sinon, on ferme le fichier et quitte la fonction
Close #hFileNum
Else
'Calcule la taille des données et dimensionne le tableau
'de donnée en fonction de la taille calculée
m_lScanLine = (((.biWidth * (.biBitCount / 8)) + 3) 4) * 4
ReDim m_byImgData(m_lScanLine - 1, .biHeight - 1) As Byte

'Obtient la référence pour la fenêtre Windows et pour son DC
hDesk = GetDesktopWindow()
hDeskDC = GetDC(hDesk)

'Creer un nouveau DIB compatible avec le DC de Windows
NewDIB hDeskDC, CInt(.biWidth), CInt(.biHeight)

'Libère la référence au DC de Windows
ReleaseDC hDesk, hDeskDC
End If
End With

Get #hFileNum, , m_byImgData() 'Lit les données de l'image

'Ferme le fichier
Close #hFileNum

'Place les données de l'image dans notre DIB
If SetDIBits(m_hDC, m_hDIB, 0, m_iHeight, m_byImgData(0, 0), InfoHead,
0) = 0 Then
MsgBox "Impossible d'initialiser l'image", vbCritical, App.Title
GoTo Terminate
End If

LoadBMP = True

Terminate:
Exit Function

ErrHandler:
lErrNum = Err.Number
GoTo Terminate
End Function

Public Function NewDIB(ByRef hDC As Long, _
ByRef iWidth As Integer, _
ByRef iHeight As Integer, _
Optional ByRef lErrNum As Long) As Boolean

On Error GoTo ErrHandler

'Supprime le DIB courant
If m_hDC <> 0 Then
KillDIB
End If

'Creer un DC compatible avec celui passé en paramètre
m_hDC = CreateCompatibleDC(hDC)

'Vérifie si la création à réussi
If m_hDC = 0 Then
'Une erreur est survenue
m_iWidth = 0
m_iHeight = 0
GoTo Terminate
End If
'Creer un DIB de la taille demandé
m_hDIB = CreateCompatibleBitmap(hDC, iWidth, iHeight)

'Vérifie si la création à fonctionné
If m_hDIB = 0 Then
'Une erreur est survenue
DeleteDC m_hDC
m_hDC = 0
m_iWidth = 0
m_iHeight = 0
GoTo Terminate
End If

'Associe le DIB à notre DC
hOldDIB = SelectObject(m_hDC, m_hDIB)

'Vérifie si l'association à fonctionné
If hOldDIB = 0 Then
'Une erreur est survenue
DeleteObject m_hDIB
DeleteDC m_hDC
m_hDC = 0
m_iWidth = 0
m_iHeight = 0
GoTo Terminate
End If

m_iWidth = iWidth
m_iHeight = iHeight

NewDIB = True

Terminate:
Exit Function

ErrHandler:
lErrNum = Err.Number
GoTo Terminate
End Function
'***

--
Cordialement
Yanick
MVP pour Visual Basic
Avatar
Zoury
ReBonjour! :O)

Oublier le message précédent... c'était atrocement buggué (aah les fins de
semaine)

Il y a maintenant trois classes :
1. Color, qui contient les informations d'une couleur tel que que les
valeurs RGB et le nombre d'occurence dans l'image
2. ColorsCounter, classe collection, qui permet de compter les couleurs au
fur et à mesure que l'on ajoute des couleurs dedans.
3. DCClass, qui permet de récupérer les infos sur l'image ainsi que le DIB.

Il est a noté que les temps réponses sont assez pitoyables avec les images
contenant beaucoup de couleurs... je ne sais pas dans quel contexte tu
comptes employés ceci, mais je ferais beaucoup de tests à ta place. ;O)

Je vais posté le projet dans le mail qui suivera.

Voici donc le nouveau code :
'***
' Module : Module1
Option Explicit

Private m_oColors As Collection

Private Sub Main()

Call LogBMPColorCount("c:image3.bmp", "c:colorcount.txt")

End Sub

Private Sub LogBMPColorCount _
( _
ByRef sFileName As String, _
ByRef sLogFileName As String _
)

Dim dc As DCClass
Dim c As Color
Dim hFile As Long

' on charge les info du bitmap
Set dc = New DCClass
Call dc.LoadBMP(sFileName)

' on écrit les infos sur le bitmap
hFile = FreeFile
Open sLogFileName For Binary As #hFile
Put #hFile, ,
"***********************************************************" & vbNewLine
Put #hFile, , "Info sur le bitmap """ & sFileName & """" & vbNewLine
Put #hFile, , "dimension de (" & dc.Width & ", " & dc.Height & ")
pixels" & vbNewLine
Put #hFile, , "résolution " & dc.BitCount & " bits" & vbNewLine
' on compte les couleurs et imprime les résultats
For Each c In GetBMPColorCount(dc)
Put #hFile, , c.ToString() & vbNewLine
Next c
Put #hFile, ,
"***********************************************************"
Close #hFile

End Sub

Private Function GetBMPColorCount(ByRef dc As DCClass) As ColorCounter

Dim cc As ColorCounter
Dim i As Long
Dim j As Long

' on récupère et compte le nombre de couleurs
Set cc = New ColorCounter
For i = 0 To dc.Height - 1
For j = 0 To dc.Width - 1
Call cc.AddRGB(dc.ImgData(3 * j + 2, i), dc.ImgData(3 * j + 1,
i), dc.ImgData(3 * j, i))
Next j
Next i

Set GetBMPColorCount = cc

End Function
'***
' Classe : Color
Option Explicit

Private m_nValue As Long
Private m_byRed As Byte
Private m_byGreen As Byte
Private m_byBlue As Byte
Private m_sKey As String
Private m_nIndex As Long
Private m_nCount As Long

Public Sub SetRGB _
( _
ByRef byRed As Byte, _
ByRef byGreen As Byte, _
ByRef byBlue As Byte _
)

m_byRed = byRed
m_byGreen = byGreen
m_byBlue = byBlue
m_nValue = RGB(byRed, byGreen, byBlue)

End Sub

Public Function ToString() As String

ToString = "0x" & Right$(String$(6, "0") & Hex$(m_nValue), 6) & _
"; RGB=(" & m_byRed & _
", " & m_byGreen & _
", " & m_byBlue & _
"); Count=" & m_nCount

End Function

Public Property Get Value() As Long
Value = m_nValue
End Property

Public Property Let Value(ByRef nValue As Long)
m_nValue = nValue
m_byRed = m_nValue And &HFF&
m_byGreen = (m_nValue And &HFF00&) / &H100&
m_byBlue = (m_nValue And &HFF0000) / &H10000
End Property

Public Property Get Red() As Byte
Red = m_byRed
End Property

Public Property Let Red(ByRef byValue As Byte)
m_byRed = byValue
m_nValue = RGB(m_byRed, m_byGreen, m_byBlue)
End Property

Public Property Get Green() As Byte
Green = m_byGreen
End Property

Public Property Let Green(ByRef byValue As Byte)
m_byGreen = byValue
m_nValue = RGB(m_byRed, m_byGreen, m_byBlue)
End Property

Public Property Get Blue() As Byte
Blue = m_byBlue
End Property

Public Property Let Blue(ByRef byValue As Byte)
m_byBlue = byValue
m_nValue = RGB(m_byRed, m_byGreen, m_byBlue)
End Property

Public Property Get Key() As String
Key = m_sKey
End Property

Friend Property Let Key(ByRef sKey As String)
m_sKey = sKey
End Property

Public Property Get Index() As Long
Index = m_nIndex
End Property

Friend Property Let Index(ByRef nIndex As Long)
m_nIndex = nIndex
End Property

Public Property Get Count() As Long
Count = m_nCount
End Property

Friend Property Let Count(ByRef nCount As Long)
m_nCount = nCount
End Property
'***
' Classe : ColorCounter
Option Explicit

Private m_colColors As Collection

Public Function Add _
( _
ByRef nValue As Long _
) As Color

Dim c As Color
Dim sKey As String

' on créer la clé pour la couleur
sKey = Hex$(nValue)

' on test l'existance de la couleur dans le compteur
' si la clé n'existe pas, alors on l'ajoute
' si non, on incrémente le compteur
On Error Resume Next
Set c = m_colColors(sKey)
If (Err.Number > 0) Then

' on instancie notre couleur
Set c = New Color
c.Value = nValue
c.Key = sKey
c.Count = 1
' et on l'ajoute à notre collection
Call m_colColors.Add(c, c.Key)
c.Index = m_colColors.Count

Else
c.Count = c.Count + 1
End If

End Function

Public Function AddRGB _
( _
ByRef byRed As Byte, _
ByRef byGreen As Byte, _
ByRef byBlue As Byte _
) As Color

Call Me.Add(RGB(byRed, byGreen, byBlue))

End Function

' afin de permettre l'énumération de la collection
' via un For Each, il faut :
' - aller dans Outils/Attributs de procédure
' - sélectionner l'item "NewEnum" dans la liste
' - cliquer sur "Avancés >>"
' - entrer -4 dans "ID de la procédure"
' - cocher "Masquer ce membre"
' - cliquez sur Appliquer
Public Function NewEnum() As IEnumVARIANT
Set NewEnum = m_colColors.[_NewEnum]
End Function

' afin de permettre l'utilisation de
' cette fonction par défaut, il faut :
' - aller dans Outils/Attributs de procédure
' - sélectionner l'item "Item" dans la liste
' - cliquer sur "Avancés >>"
' - sélectionner "(par défaut)" dans "ID de la procédure"
' - cliquez sur Appliquer
Public Function Item(ByRef nIndex As Variant) As Color
Set Item = m_colColors.Item(nIndex)
End Function

Public Function Count() As Long
Count = m_colColors.Count
End Function

Public Sub Delete(ByVal nIndex As Variant)
Call m_colColors.Remove(nIndex)
End Sub

Private Sub Class_Initialize()
Set m_colColors = New Collection
End Sub

Private Sub Class_Terminate()
Set m_colColors = Nothing
End Sub
'***
Classe : DCClass
'********************************************
' Source original : Mike D Sutton
' Adapté par : Yanick Lefebvre
'********************************************
'Option Explicit

Private Declare Function CreateCompatibleBitmap _
Lib "gdi32" ( _
ByVal hDC As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC _
Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject _
Lib "gdi32" ( _
ByVal hDC As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject _
Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function ReleaseDC _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function DeleteDC _
Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd 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 BITMAPINFOHEADER, _
ByVal wUsage As Long) As Long

'Information relative à l'entête du bitmap
Private Type BITMAPINFOHEADER '40 bytes
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

'Information relative à l'entête du fichier
Private Type BITMAPFILEHEADER '14 bytes
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type

Private m_hDC As Long 'Référence au DC
Private m_hDIB As Long 'Référence as DIB
Private m_iWidth As Integer 'Largeur du DIB
Private m_iHeight As Integer 'Hauteur du DIB
Private m_hPen As Long 'Référence au crayon
Private m_hBrush As Long 'Référence à la pinceau
Private m_hFont As Long 'Référence à la police de charactère
Private m_byImgData() As Byte 'Donnée de l'image
Private m_lScanLine As Long 'Longueur d'une ligne en pixel
Private m_lBitCount As Long 'Résolution du bitmap

Private hOldDIB As Long 'Ancienne référence au DIB
Private hOldPen As Long 'Ancienne référence au crayon
Private hOldBrush As Long 'Ancienne référence a la pinceau
Private hOldFont As Long 'Ancienne référence à la police de charactère

Private Const bmMagicCookie = &H4D42 'Entête de Bitmap "BM"


Private Sub Class_Terminate()

On Error GoTo ErrHandler

KillDIB 'Détruit le DIB
KillPen 'Détruit le crayon
KillBrush 'Détruit la pinceau
KillFont 'Détruit la police

Terminate:
Exit Sub

ErrHandler:
GoTo Terminate
End Sub

Public Property Get Width() As Integer
Width = m_iWidth
End Property

Public Property Get Height() As Integer
Height = m_iHeight
End Property

Public Property Get ImgData(ByRef i1 As Long, ByRef i2 As Long) As Byte
ImgData = m_byImgData(i1, i2)
End Property

Public Property Get BitCount() As Long
BitCount = m_lBitCount
End Property

Private Sub KillBrush(Optional ByRef lErrNum As Long)

On Error GoTo ErrHandler

'Vérifie si la brosse existe
If m_hBrush <> 0 Then

'Change la brosse sélectionnée
SelectObject m_hDC, hOldBrush

'Supprime la brosse
DeleteObject m_hBrush

'Efface la référence à la brosse
m_hBrush = 0
End If

Terminate:
Exit Sub

ErrHandler:
lErrNum = Err.Number
GoTo Terminate
End Sub

Public Sub KillDIB(Optional ByRef lErrNum As Long)

On Error GoTo ErrHandler

'Vérifie si notre DIB existe
If m_hDC <> 0 Then

'Déselectionne le DIB sélectionné
SelectObject m_hDC, hOldDIB

'Détruit le DIB
DeleteObject m_hDC

'Détruit le DC
DeleteDC m_hDC

'Efface les dimensions
m_iWidth = 0
m_iHeight = 0

'Efface la référence au DC
m_hDC = 0
End If

Terminate:
Exit Sub

ErrHandler:
lErrNum = Err.Number
GoTo Terminate
End Sub

Public Sub KillFont(Optional ByRef lErrNum As Long)

On Error GoTo ErrHandler

'Vérifie si la police existe
If m_hFont <> 0 Then

'Change la police sélectionnée
SelectObject m_hDC, hOldFont

'Supprime la police
DeleteObject m_hFont

'Efface la référence à la police
m_hFont = 0
End If

Terminate:
Exit Sub

ErrHandler:
lErrNum = Err.Number
GoTo Terminate
End Sub

Private Sub KillPen(Optional ByRef lErrNum As Long)

On Error GoTo ErrHandler

'Vérifie si le crayon existe
If m_hPen <> 0 Then

'Change le crayon sélectionné
SelectObject m_hDC, hOldPen

'Supprime le crayon
DeleteObject m_hPen

'Efface la référence au crayon
m_hPen = 0
End If

Terminate:
Exit Sub

ErrHandler:
lErrNum = Err.Number
GoTo Terminate
End Sub

Public Function LoadBMP(ByRef sFile As String, _
Optional ByRef lErrNum As Long) As Boolean

Dim FileHead As BITMAPFILEHEADER
Dim InfoHead As BITMAPINFOHEADER
Dim hFileNum As Long 'Référence au fichier
Dim hDesk As Long
Dim hDeskDC As Long

On Error GoTo ErrHandler

'Vérifie si le fichier existe
If LenB(Dir(sFile)) = 0 Then
MsgBox "Fichier inexistant", vbCritical, App.Title
GoTo Terminate
End If

'Détruit l'image courante
If m_hDC <> 0 Then
KillDIB
End If

'Obtient une nouvelle référence de fichier
hFileNum = FreeFile

'Ouvre le fichier
Open sFile For Binary As #hFileNum
'Lit l'entête du fichier
Get #hFileNum, , FileHead 'File header

'Vérifie l'entête pour être sure que c'est un bitmap
If FileHead.bfType <> bmMagicCookie Then
MsgBox "Ce fichier n'est un bitmap valide", vbCritical,
App.Title

'Ferme le fichier et quitte la fonction
Close #hFileNum
GoTo Terminate
End If

Get #hFileNum, , InfoHead 'Lit l'entête de l'image

With InfoHead
'Vérifie si l'image est une image de format 24bit
If .biBitCount <> 24 Or _
.biCompression <> 0 Or _
.biPlanes <> 1 Or _
.biHeight < 1 Or _
.biWidth < 1 Then

'Sinon, on ferme le fichier et quitte la fonction
Close #hFileNum
Else

m_lBitCount = .biBitCount

'Calcule la taille des données et dimensionne le tableau
'de donnée en fonction de la taille calculée
m_lScanLine = (((.biWidth * .biBitCount) + &H1F) And Not
&H1F) &H8
ReDim m_byImgData(m_lScanLine - 1, .biHeight - 1) As Byte

'Obtient la référence pour la fenêtre Windows et pour son DC
hDesk = GetDesktopWindow()
hDeskDC = GetDC(hDesk)

'Creer un nouveau DIB compatible avec le DC de Windows
NewDIB hDeskDC, CInt(.biWidth), CInt(.biHeight)

'Libère la référence au DC de Windows
ReleaseDC hDesk, hDeskDC
End If
End With

Get #hFileNum, , m_byImgData() 'Lit les données de l'image

'Ferme le fichier
Close #hFileNum

'Place les données de l'image dans notre DIB
If SetDIBits(m_hDC, m_hDIB, 0, m_iHeight, m_byImgData(0, 0), InfoHead,
0) = 0 Then
MsgBox "Impossible d'initialiser l'image", vbCritical, App.Title
GoTo Terminate
End If

LoadBMP = True

Terminate:
Exit Function

ErrHandler:
lErrNum = Err.Number
GoTo Terminate
End Function

Public Function NewDIB(ByRef hDC As Long, _
ByRef iWidth As Integer, _
ByRef iHeight As Integer, _
Optional ByRef lErrNum As Long) As Boolean

On Error GoTo ErrHandler

'Supprime le DIB courant
If m_hDC <> 0 Then
KillDIB
End If

'Creer un DC compatible avec celui passé en paramètre
m_hDC = CreateCompatibleDC(hDC)

'Vérifie si la création à réussi
If m_hDC = 0 Then
'Une erreur est survenue
m_iWidth = 0
m_iHeight = 0
GoTo Terminate
End If
'Creer un DIB de la taille demandé
m_hDIB = CreateCompatibleBitmap(hDC, iWidth, iHeight)

'Vérifie si la création à fonctionné
If m_hDIB = 0 Then
'Une erreur est survenue
DeleteDC m_hDC
m_hDC = 0
m_iWidth = 0
m_iHeight = 0
GoTo Terminate
End If

'Associe le DIB à notre DC
hOldDIB = SelectObject(m_hDC, m_hDIB)

'Vérifie si l'association à fonctionné
If hOldDIB = 0 Then
'Une erreur est survenue
DeleteObject m_hDIB
DeleteDC m_hDC
m_hDC = 0
m_iWidth = 0
m_iHeight = 0
GoTo Terminate
End If

m_iWidth = iWidth
m_iHeight = iHeight

NewDIB = True

Terminate:
Exit Function

ErrHandler:
lErrNum = Err.Number
GoTo Terminate
End Function
'***

--
Cordialement
Yanick
MVP pour Visual Basic
1 2