İki Resmi Karşılaştırma

Arkadaşlar karşılaştırmak istediğiniz aynı olduğunu düşündüğünüz iki resmi karşılaştırmaya yarıyor. İkinci resimde ufak bir nokta olsada buluyor.

http://hotfile.com/dl/123561038/3ee9baa/Resim_Karlatrma.exe.html

KODLARI:
------------------------------------------------------------------------------------------------------------

Private Sub Form_Load()
 Combo1.AddItem "*.bmp"
 Combo1.AddItem "*.jpg"
 Combo1.AddItem "*.gif"
 Combo1.ListIndex = 1
 File1.Pattern = Combo1.Text
 Combo2.AddItem "*.bmp"
 Combo2.AddItem "*.jpg"
 Combo2.AddItem "*.gif"
 Combo2.ListIndex = 1
 File2.Pattern = Combo2.Text
 MsgBox "Program Ayni Iki Resmin Arasinda Fark Olup Olmadigina Bakmak Için Yapildi", , "ÖNEMLI"
 End Sub
 --------------------------------------------------
 Private Sub Command1_Click()
 MsgBox CompareImage(Picture1, Picture2)
 End Sub
 '-------------------------------------------
 Private Sub Combo1_Click()
 File1.Pattern = Combo1.Text
 End Sub
 '-----------------------------------
 Private Sub Dir1_Change()
 File1.Path = Dir1.Path
 End Sub
 '------------------------------------
 Private Sub Drive1_Change()
 Dir1.Path = Drive1.Drive
 End Sub
 '----------------------------------------
 Private Sub Combo2_Click()
 File2.Pattern = Combo2.Text
 End Sub
 '---------------------------------------
 Private Sub Dir2_Change()
 File2.Path = Dir2.Path
 End Sub
 '---------------------------------------
 Private Sub Drive2_Change()
 Dir2.Path = Drive2.Drive
 End Sub
 '------------------------------------------------------------------
 Private Sub File1_Click()
 Dim FName As String
 On Error GoTo LoadPictureError
 FName = File1.Path + "\" + File1.FileName
 MousePointer = vbHourglass
 DoEvents
 Picture1.Picture = LoadPicture(FName)
 'Picture1.Picture = LoadPicture(FName)
 MousePointer = vbDefault

 Exit Sub
 LoadPictureError:
 Beep
 MousePointer = vbDefault
 Exit Sub
 End Sub
 --------------------------------------------------------
 Private Sub File2_Click()
 Dim FName As String
 On Error GoTo LoadPictureError
 FName = File2.Path + "\" + File2.FileName
 MousePointer = vbHourglass
 DoEvents
 Picture2.Picture = LoadPicture(FName)
 'Picture1.Picture = LoadPicture(FName)
 MousePointer = vbDefault

 Exit Sub
 LoadPictureError:
 Beep
 MousePointer = vbDefault
 Exit Sub
 End Sub
 '----------------------------------------------------
 '-----------------------------------------------------
 Aşagıdaki kodları da module kopyalayın:
 ---------------------------------------------------
 Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
 Public Declare Function VarPtr Lib "msvbvm60.dll" (Ptr As Any) As Long
 Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
 Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
 Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
 Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
 Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
 Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
 Public Type SAFEARRAYBOUND
 cElements As Long
 lLbound As Long
 End Type
 Public Type SAFEARRAY2D
 cDims As Integer
 fFeatures As Integer
 cbElements As Long
 cLocks As Long
 pvData As Long
 Bounds(0 To 1) As SAFEARRAYBOUND
 End Type
 Public Type BITMAP
 bmType As Long
 bmWidth As Long
 bmHeight As Long
 bmWidthBytes As Long
 bmPlanes As Integer
 bmBitsPixel As Integer
 bmBits As Long
 End Type
 Public Type OffScreenDC
 DC As Long
 Object As IPictureDisp
 End Type
 Public MyPict1 As OffScreenDC
 Public MyPict2 As OffScreenDC
 Public Function CompareDCs(ByRef MyPict1 As OffScreenDC, ByRef MyPict2 As OffScreenDC) As Boolean
 Dim i As Integer
 Dim j As Integer
 Dim pic1() As Byte
 Dim pic2() As Byte
 Dim sa1 As SAFEARRAY2D
 Dim sa2 As SAFEARRAY2D
 Dim bmp1 As BITMAP
 Dim bmp2 As BITMAP
 Dim sR As Integer, sG As Integer, sB As Integer
 Erase pic1
 Erase pic2
 'First Pic...
 'Pass the IPictureDisp object to get its details...
 GetObjectAPI MyPict1.Object, Len(bmp1), bmp1
 With sa1
 .cbElements = 1
 .cDims = 2
 .Bounds(0).lLbound = 0
 .Bounds(0).cElements = bmp1.bmHeight
 .Bounds(1).lLbound = 0
 .Bounds(1).cElements = bmp1.bmWidthBytes
 .pvData = bmp1.bmBits
 End With
 CopyMemory ByVal VarPtrArray(pic1), VarPtr(sa1), 4
 GetObjectAPI MyPict2.Object, Len(bmp2), bmp2

 With sa2
 .cbElements = 1
 .cDims = 2
 .Bounds(0).lLbound = 0
 .Bounds(0).cElements = bmp2.bmHeight
 .Bounds(1).lLbound = 0
 .Bounds(1).cElements = bmp2.bmWidthBytes
 .pvData = bmp2.bmBits
 End With
 CopyMemory ByVal VarPtrArray(pic2), VarPtr(sa2), 4

 If sa2.Bounds(0).cElements <> sa1.Bounds(0).cElements Then 'just compare image height first
 CompareDCs = False
 Exit Function
 End If
 CompareDCs = True
 For i = 0 To UBound(pic1, 1) - 1 'Step 3
 For j = 0 To UBound(pic1, 2)
 If pic1(i, j) <> pic2(i, j) Then 'check pixels
 pic1(i, j) = 0
 CompareDCs = False
 'Exit Function
 End If
 Next
 Next
 'Clear the link...
 CopyMemory ByVal VarPtrArray(pic1), 0&, 4
 CopyMemory ByVal VarPtrArray(pic2), 0&, 4
 Erase pic1
 Erase pic2
 End Function
 Public Sub LoadDCs(ByRef MyPict As OffScreenDC, ByVal iFilename As PictureBox)
 'Create compatible DC...
 MyPict.DC = CreateCompatibleDC(0)
 Set MyPict.Object = iFilename.Picture
 SelectObject MyPict.DC, MyPict.Object
 End Sub
 Public Function CompareImage(ByVal FirstImage As Object, ByVal SecondImage As Object) As Boolean
 LoadDCs MyPict1, FirstImage
 LoadDCs MyPict2, SecondImage
 CompareImage = CompareDCs(MyPict1, MyPict2)

 DeleteDC MyPict1.DC
 DeleteDC MyPict2.DC
 Set MyPict1.Object = Nothing
 Set MyPict2.Object = Nothing
 End Function

----------------------------------------------------------------------------------------------------------------

Categories: Visual Basic