compare emails through Subject doesn't work

[vonClausowitz]

Hi All,

We have two accounts on which emails arrive. A lot of the time the
same emails arrive at both accounts so we created this code to check
the inbox of account2 with the deleted items of account1. We do the
check on subject and time of arrival. The time of arrival should lay
within one hour, due to the different networks used and the
subjectline is also checked. If an email meets both criteria it is
considered the same.
Somehow our code doesn't work for all the emails. Sometimes for no
reason some emails aren't considered double although the subject line
is the same.
Anyone knows what's wrong or has a better idea to remove duplicates.

Private Sub cmdInlezen2_Click()

Dim objFoundItems As Outlook.Items
Dim objItem As Object, objFoundItem As Object
Dim strCrit As String
Dim dCentDeet As Date
Dim xDatum As Date
Dim i, j, iNumItems, iNumOwnItems As Integer
Dim rst, rstTarget As Recordset
Dim sFoutKar, sGoedKar As String
Dim lGeenSubject As Long
Dim olOwnDeleteFolder As Outlook.MAPIFolder

sFoutKar = Chr(30)
sGoedKar = " "
Ready2Go = False

Set rst = dbSettings.OpenRecordset("tblInbox", dbOpenTable)

Do While Not rst.EOF
rst.Delete
rst.MoveNext
Loop

'On Error GoTo SHIT:
If chkAutoPickFolder.Value = 1 Then
Set olOwnDeleteFolder = oNamespace.PickFolder
Else
If sys.gWelkeFolder = "Inbox" Then
Set olOwnDeleteFolder =
olApplication.Session.GetDefaultFolder(olFolderInbox) 'mijn inbox
Else
Set olOwnDeleteFolder =
olApplication.Session.GetDefaultFolder(olFolderDeletedItems)
End If
End If
Set olDeleteFolder =
oNamespace.folders(sys.gMasterAccount).folders("Verwijderde items")

If sys.sTaalKeuze = "US" Then
olDeleteFolder.Items.Sort ("[Received]"), True 'indexeren op
datum, laatste als eerst
Else
olDeleteFolder.Items.Sort ("[Ontvangen]"), True 'indexeren op
datum, laatste als eerst
End If

xDatum = sys.dLaatsteDatum
j = 0 'aantal gevonden dubbele emails
iNumItems = olDeleteFolder.Items.Count
iNumOwnItems = olOwnDeleteFolder.Items.Count

For Each objItem In olDeleteFolder.Items
If objItem.Class = olMail Then 'alleen echte emails
vergelijken
lblDatum.Caption = objItem.ReceivedTime
lblEmail.Caption = Left(objItem.Subject, 45)
dCentDeet = objItem.SentOn
'sla de datum van de email in verwijderde items op
If xDatum < objItem.ReceivedTime Then xDatum =
objItem.ReceivedTime
strCrit = Replace(objItem.Subject, """, """"", 1, ,
vbTextCompare)
strCrit = Replace(strCrit, "'", "''", 1, , vbTextCompare)
'haal evt. de chr(30) eruit
strCrit = Replace(strCrit, sFoutKar, sGoedKar, 1, ,
vbTextCompare)
If sys.sTaalKeuze = "US" Then
Set objFoundItems =
olOwnDeleteFolder.Items.Restrict("[Subject] = '" & strCrit & "'")
Else
Set objFoundItems =
olOwnDeleteFolder.Items.Restrict("[Onderwerp] = '" & strCrit & "'")
End If
If objFoundItems.Count > 0 Then
If sys.sTaalKeuze = "US" Then
objFoundItems.Sort ("[Received]"), True
Else
objFoundItems.Sort ("[Ontvangen]"), True
End If
For Each objFoundItem In objFoundItems
'email zonder onderwerp is niet te vergelijken
If objItem.Subject = "" Then
lGeenSubject = MsgBox("Email zonder Subject
overslaan?", vbYesNo + vbExclamation, "Waarschuwing")
If lGeenSubject = vbYes Then
GoTo NoSubject
End If
End If
If objItem.Class <> olMail Then 'alleen echte emails
vergelijken
'deze item overslaan
GoTo NoSubject
End If
'emails from the same day?
If DateDiff("d", objFoundItem.SentOn, dCentDeet) = 0
Then
'within one hour?
If Abs(DateDiff("n", objFoundItem.SentOn,
dCentDeet)) < 60 Then
objFoundItem.FlagStatus = olFlagMarked
objFoundItem.Save
With rst
rst.AddNew
rst("From") = objFoundItem.SenderName
rst("Subject") =
Left(objFoundItem.Subject, 255)
rst("Received") =
objFoundItem.ReceivedTime
rst("SentDTG") = objFoundItem.SentOn
rst.Update
End With
FillMyGrid
j = j + 1
txtProgress.Text = j & " Dubbele Items gevonden
in " & olOwnDeleteFolder & " van " & sys.gUser
End If
End If
NoSubject:
Next '''''''
End If
End If
i = i + 1
Call PctMeter(i, iNumItems)
DoEvents
If j = iNumOwnItems Then
i = iNumItems
Call PctMeter(i, iNumItems)
DoEvents
GoTo skip:
End If
If Ready2Go = True Then
i = iNumItems
Call PctMeter(i, iNumItems)
DoEvents
GoTo skip:
End If
Next

skip:

rst.Close
Call ProfileSaveSetting("Data", "laatstedatum", CStr(xDatum))

lblDatum.Caption = ""
lblEmail.Caption = ""
txtLaatsteEmails = xDatum
Me.Refresh

If chkAutoCompare.Value = 1 Then
ProgressBar1.Value = 0 'progressbar leegmaken
'automatisch dubbele verwijderen maar alleen als die er zijn
If j <> 0 Then
cmdRemoveItems_Click
End If
End If
Set rst = Nothing
Set rstTarget = Nothing
j = 0

SHIT:
Select Case Err.Number
Case -1767768055 'verkeerde taalinstelling
MsgBox "Controleer de Taalinstelling", vbCritical
Case -2147221233 'folder niet gevonden
MsgBox "Kan een Outlook Folder niet vinden", vbCritical
End Select

End Sub



Regards
Marco