MP3 Duplicates Searching program
Hello,
I have very difficult question (For me ;])
I'm making program witch would find duplicates in listview, but it wouldn't match 100%. For instance "ABCDE" and "ABCDF" would return 80%. It would be very useful for making program witch searches for duplicates mp3 songs (Almost same filenames, but not 100% match)
I have done it, but my code is very slow. To search for duplicates in listview with 2500 items would take about 40 hours. How to optimize this code? (Earlier I used function .FindItem, it is very fast, but this search would found items, witch matches 100%)
Listfiles1 = Listview (with filenames)
Duplicates = Listview (duplicates items)
My Code:
Code:
Private Sub FNDDPLBYNAME()
Dim x0, x1
Dim File0 As String, File1 As String
Dim ListViewItemX As ListItem
For x0 = 1 To ListFiles.ListItems.Count
File0 = Trim$(ListFiles.ListItems.Item(x0).Text)
File0 = Left$(File0, Len(File0) - 4)
For x1 = x0 + 1 To ListFiles.ListItems.Count
File1 = Trim$(ListFiles.ListItems.Item(x1).Text)
File1 = Left$(File1, Len(File1) - 4)
DoEvents
Debug.Print x0
If CompareTXT(File0, File1) >= 80 Then ' 80%, or other number to match songs filenames
Duplicates.ListItems.Add , , ListFiles.ListItems.Item(x0).Text
Duplicates.ListItems.Add , , ListFiles.ListItems.Item(x1).Text
End If
Next x1
Next x0
End Sub
Public Function CompareTXT(String1 As String, String2 As String) As Single
Dim i, y, x As Integer
Dim a, b As String
String1 = UCase$(String1) 'take this out If you
String2 = UCase$(String2) 'want it To be case
'sensitive
If String1 = String2 Then CompareTXT = 1: Exit Function
'if the strings are
'the same, don't
'bother to waste time
'and space on working
'them out :).
If Len(String1) > Len(String2) Then x = Len(String1)
If Len(String2) > Len(String1) Then x = Len(String2)
If Len(String1) = Len(String2) Then x = Len(String1)
'find out the length
'of the longest string
For i = 1 To x
DoEvents
a = Mid$(String1, i, 1) 'get 1 character from
b = Mid$(String2, i, 1) 'each string and compare
If a = b Then y = y + 1 'the characters
Next
CompareTXT = y / x * 100
End Function
Regards,
Norkis
Re: MP3 Duplicates Searching program
This should increase the speed a bit
VB Code:
Public Function CompareTXT(String1 As String, String2 As String) As Single
Dim i, y, x As Integer
Dim a, b As String
String1 = UCase$(String1) 'take this out If you
String2 = UCase$(String2) 'want it To be case
'sensitive
If String1 = String2 Then CompareTXT = 1: Exit Function
'if the strings are
'the same, don't
'bother to waste time
'and space on working
'them out :).
If Len(String1) => Len(String2) Then
x = Len(String1)
Else
x = Len(String2)
End If
'If Len(String2) > Len(String1) Then x = Len(String2)
'If Len(String1) = Len(String2) Then x = Len(String1)
'find out the length
'of the longest string
For i = 1 To x
'DoEvents
'a = Mid$(String1, i, 1) 'get 1 character from
'b = Mid$(String2, i, 1) 'each string and compare
'If a = b Then y = y + 1 'the characters
If Mid$(String1, i, 1) = Mid$(String2, i, 1) Then y = y + 1
Next
CompareTXT = y / x * 100
End Function
