merhaba arkadaşlar uzun suredir aradıgım kodları buldum ve paylaşmak istedim bu kod iki resim arasındakı farkı yuzde olarak veriyo iki adet picture uc adet buton eklemeniz yeterli kullanımı iki adet aynı resmi koyunuz picturelere ve Private Sub Command1_Click() basınız 100 de 100 diyecektir daha sonra resmin birini mausun butonuna basılı tutara (poınt)gibi cizgi ciziniz deger degişecektir

alıntıdır:

kod:

'Resemblance both Picture
'programmer: SAEED SHEIKHOLESLAMI
'E -mail:: [email protected] yahoo.com
Dim one, two, D
Private Sub B1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
B1.PSet (X, Y) ' for drawing on picture1
End If
End Sub
Private Sub B2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
B2.PSet (X, Y) ' for drawing on picture2
End If
End Sub
Sub PaP(p1 As PictureBox, p2 As PictureBox, W As Long, H As Long, C As Long, DDD)
Dim X, Y, a, AP, DD1, DD2
D = 10 ' for decimal digit in percentile part. d= 1 or 10 or 100
For X = 0 To W - 15 Step C ' StepbyStep for PixelComparable of both picture
For Y = 0 To H - 15 Step C
If p2.Point(X, Y) = p1.Point(X, Y) Then AP = AP + 1 ' if picture1 pointcolor= picture2 pointcolor |>counter=++1
a = a + 1 ' a=programme counter
Next
Next
DD1 = (AP * 100) \ a 'percentile
DD2 = Right$((AP * (100 * D)) \ a, Len(D) - 1) 'decimal part
DDD = DD1 & "." & DD2 & "%" ' wrought percent
End Sub
Private Sub Command1_Click()
PaP B1, B2, B1.Width, B2.Height, 15, one
MsgBox one
End Sub

Private Sub Command3_Click()
B1.Cls 'ClearScreen
End Sub

Private Sub Command2_Click()
B2.Cls 'ClearScreen
End Sub

Private Sub Form_Load()
B1.DrawWidth = 4 ' size pen=4 in both picture
B2.DrawWidth = 4
End Sub
__________________