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
Zoury
Salut Brice! :O)
La façon la plus rapide qui me vient à l'esprit est de récupéré le DIB de tes PictureBoxes et de boucler les octets de ceux afin de les comparer un à un...
'*** ' Form1 ' 2 PictureBoxes Option Explicit
Private Declare Function GetDIBits _ Lib "gdi32" _ ( _ ByVal aHDC As Long, _ ByVal hBitmap As Long, _ ByVal nStartScan As Long, _ ByVal nNumScans As Long, _ ByRef lpvBits As Any, _ ByRef lpBI As BitmapInfo8, _ ByVal wUsage As Long _ ) As Long
Private Declare Function GetDC _ Lib "user32" _ ( _ ByVal hwnd As Long _ ) As Long
Private Declare Function ReleaseDC _ Lib "user32" _ ( _ ByVal hwnd As Long, _ ByVal hDC As Long _ ) As Long
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
Private Type BitmapInfo8 bmiHeader As BitmapInfoHeader bmiColors(255) As Long End Type
Private Sub Form_Load() Set Picture1.Picture = LoadPicture("c:Image.bmp") Set Picture2.Picture = LoadPicture("c:2Jours.bmp") Debug.Print ComparePictures(Picture1.Picture, Picture2.Picture) End Sub
Private Function ComparePictures(ByRef pic1 As StdPicture, ByRef pic2 As StdPicture) As Boolean
Dim by1() As Byte Dim by2() As Byte Dim i As Long
by1 = GetDIBData(pic1) by2 = GetDIBData(pic2)
' Vérifie les tailles... If (Not IsArrayInit(by1) Or Not IsArrayInit(by2)) Then Exit Function If (LBound(by1) <> LBound(by2) Or UBound(by1) <> UBound(by2)) Then Exit Function
' Vérifie le contenu For i = 0 To UBound(by1) If (by1(i) <> by2(i)) Then Exit Function Next i
ComparePictures = True
End Function
Private Function GetDIBData(ByRef pic As StdPicture) As Byte()
Dim by() As Byte Dim bi As BitmapInfo8 Const DIB_RGB_COLORS = 0
Dim hDC As Long hDC = GetDC(0) ' Desktop
bi.bmiHeader.biSize = LenB(bi.bmiHeader) If GetDIBits(hDC, pic.Handle, 0, 0, ByVal 0&, bi, DIB_RGB_COLORS) Then ReDim by(bi.bmiHeader.biSizeImage - 1) As Byte Call GetDIBits(hDC, pic.Handle, 0, bi.bmiHeader.biHeight, by(0), bi, DIB_RGB_COLORS) End If
GetDIBData = by
Call ReleaseDC(0&, hDC)
End Function
Private Function IsArrayInit(ByVal v As Variant) As Boolean On Error Resume Next v = UBound(v) IsArrayInit = (Err.Number <> 9 And Err.Number <> 13) End Function '***
Merci de poster les réponses au groupe afin d'en faire profiter à tous "Brice" wrote in message news:blu7tg$qbj$
Bonjour,
Est-il possible de comparer deux picture box pour savoir si elles contiennent la même image.
Merci
Brice
Salut Brice! :O)
La façon la plus rapide qui me vient à l'esprit est de récupéré le DIB de
tes PictureBoxes et de boucler les octets de ceux afin de les comparer un à
un...
'***
' Form1
' 2 PictureBoxes
Option Explicit
Private Declare Function GetDIBits _
Lib "gdi32" _
( _
ByVal aHDC As Long, _
ByVal hBitmap As Long, _
ByVal nStartScan As Long, _
ByVal nNumScans As Long, _
ByRef lpvBits As Any, _
ByRef lpBI As BitmapInfo8, _
ByVal wUsage As Long _
) As Long
Private Declare Function GetDC _
Lib "user32" _
( _
ByVal hwnd As Long _
) As Long
Private Declare Function ReleaseDC _
Lib "user32" _
( _
ByVal hwnd As Long, _
ByVal hDC As Long _
) As Long
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
Private Type BitmapInfo8
bmiHeader As BitmapInfoHeader
bmiColors(255) As Long
End Type
Private Sub Form_Load()
Set Picture1.Picture = LoadPicture("c:Image.bmp")
Set Picture2.Picture = LoadPicture("c:2Jours.bmp")
Debug.Print ComparePictures(Picture1.Picture, Picture2.Picture)
End Sub
Private Function ComparePictures(ByRef pic1 As StdPicture, ByRef pic2 As
StdPicture) As Boolean
Dim by1() As Byte
Dim by2() As Byte
Dim i As Long
by1 = GetDIBData(pic1)
by2 = GetDIBData(pic2)
' Vérifie les tailles...
If (Not IsArrayInit(by1) Or Not IsArrayInit(by2)) Then Exit Function
If (LBound(by1) <> LBound(by2) Or UBound(by1) <> UBound(by2)) Then Exit
Function
' Vérifie le contenu
For i = 0 To UBound(by1)
If (by1(i) <> by2(i)) Then Exit Function
Next i
ComparePictures = True
End Function
Private Function GetDIBData(ByRef pic As StdPicture) As Byte()
Dim by() As Byte
Dim bi As BitmapInfo8
Const DIB_RGB_COLORS = 0
Dim hDC As Long
hDC = GetDC(0) ' Desktop
bi.bmiHeader.biSize = LenB(bi.bmiHeader)
If GetDIBits(hDC, pic.Handle, 0, 0, ByVal 0&, bi, DIB_RGB_COLORS) Then
ReDim by(bi.bmiHeader.biSizeImage - 1) As Byte
Call GetDIBits(hDC, pic.Handle, 0, bi.bmiHeader.biHeight, by(0), bi,
DIB_RGB_COLORS)
End If
GetDIBData = by
Call ReleaseDC(0&, hDC)
End Function
Private Function IsArrayInit(ByVal v As Variant) As Boolean
On Error Resume Next
v = UBound(v)
IsArrayInit = (Err.Number <> 9 And Err.Number <> 13)
End Function
'***
Merci de poster les réponses au groupe afin d'en faire profiter à tous
"Brice" <brice.lerendu@fr.bosch.com> wrote in message
news:blu7tg$qbj$1@ns2.fe.internet.bosch.com...
Bonjour,
Est-il possible de comparer deux picture box pour savoir si elles
contiennent la même image.
La façon la plus rapide qui me vient à l'esprit est de récupéré le DIB de tes PictureBoxes et de boucler les octets de ceux afin de les comparer un à un...
'*** ' Form1 ' 2 PictureBoxes Option Explicit
Private Declare Function GetDIBits _ Lib "gdi32" _ ( _ ByVal aHDC As Long, _ ByVal hBitmap As Long, _ ByVal nStartScan As Long, _ ByVal nNumScans As Long, _ ByRef lpvBits As Any, _ ByRef lpBI As BitmapInfo8, _ ByVal wUsage As Long _ ) As Long
Private Declare Function GetDC _ Lib "user32" _ ( _ ByVal hwnd As Long _ ) As Long
Private Declare Function ReleaseDC _ Lib "user32" _ ( _ ByVal hwnd As Long, _ ByVal hDC As Long _ ) As Long
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
Private Type BitmapInfo8 bmiHeader As BitmapInfoHeader bmiColors(255) As Long End Type
Private Sub Form_Load() Set Picture1.Picture = LoadPicture("c:Image.bmp") Set Picture2.Picture = LoadPicture("c:2Jours.bmp") Debug.Print ComparePictures(Picture1.Picture, Picture2.Picture) End Sub
Private Function ComparePictures(ByRef pic1 As StdPicture, ByRef pic2 As StdPicture) As Boolean
Dim by1() As Byte Dim by2() As Byte Dim i As Long
by1 = GetDIBData(pic1) by2 = GetDIBData(pic2)
' Vérifie les tailles... If (Not IsArrayInit(by1) Or Not IsArrayInit(by2)) Then Exit Function If (LBound(by1) <> LBound(by2) Or UBound(by1) <> UBound(by2)) Then Exit Function
' Vérifie le contenu For i = 0 To UBound(by1) If (by1(i) <> by2(i)) Then Exit Function Next i
ComparePictures = True
End Function
Private Function GetDIBData(ByRef pic As StdPicture) As Byte()
Dim by() As Byte Dim bi As BitmapInfo8 Const DIB_RGB_COLORS = 0
Dim hDC As Long hDC = GetDC(0) ' Desktop
bi.bmiHeader.biSize = LenB(bi.bmiHeader) If GetDIBits(hDC, pic.Handle, 0, 0, ByVal 0&, bi, DIB_RGB_COLORS) Then ReDim by(bi.bmiHeader.biSizeImage - 1) As Byte Call GetDIBits(hDC, pic.Handle, 0, bi.bmiHeader.biHeight, by(0), bi, DIB_RGB_COLORS) End If
GetDIBData = by
Call ReleaseDC(0&, hDC)
End Function
Private Function IsArrayInit(ByVal v As Variant) As Boolean On Error Resume Next v = UBound(v) IsArrayInit = (Err.Number <> 9 And Err.Number <> 13) End Function '***