porque me Duplica los correos?

FaBioLa Renteria escribió el 07/07/2004 18:16 :

Hola que tal... Bueno yo tengo un problema, resulta que
los correos me llegan pero de 3 hasta 6 veces el mismo,
el motivo no lo se si alguien me pudiese ayudar pues lo
agradeceria enormemente
uso Windows Xp Profesional y es Microsoft Outlook 2002

Saludos y espero comentarios

Fabiola Renteria Ruiz

LA SOLUCION AL PROBLEMA:

Sub Supr_Duplicados()

Dim Contador As Integer, Fecha As Date, Fecha1 As Date

Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Ite As Object
Dim i As Integer
Dim SubFolder As MAPIFolder
Dim Destino As String

Dim olAE As Outlook.AddressEntry

GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Set ns = GetNamespace("MAPI")
Set oApp = New Outlook.Application

i = 0
Contador = 0

Set Inbox = ns.GetDefaultFolder(olFolderInbox)

If Inbox.Items.Count = 0 Then
MsgBox "No hay mensajes en tu bandeja de " & Bandeja & ".", vbInformation, _
"Nada de lo encontrado"
Exit Sub
End If

Rta = "c:\Ar.are"

For Each Item In Inbox.Items

Remitente0 = ""
Remitente1 = ""
Asunto = ""
Fecha = 0
Asunto = Item.Subject

If InStr(UCase(Asunto), "READ") = 0 And InStr(UCase(Asunto), "LEÍDO") = 0 And InStr(UCase(Asunto), "ENTREGADO") = 0 And InStr(UCase(Asunto), "NO SE PUEDE ENTREGAR") = 0 Then

Remitente0 = Item.SenderName
Remitente1 = Item.SenderEmailAddress
Fecha = Item.ReceivedTime
Elimina = ""

If Dir(Rta) <> "" Then
Open Rta For Input As #1
While Not EOF(1)
Input #1, Remi0, Remi1, Fecha1, Asunto1
If Remi0 = Remitente0 And Remi1 = Remitente1 And Fecha = Fecha1 And Asunto = Asunto1 Then
Elimina = 1
End If
Wend
Close
If Elimina = 1 Then
Item.Delete
Contador = Contador + 1
Elimina = ""
Else
Open Rta For Append As #1
Write #1, Remitente0, Remitente1, Fecha, Asunto
Close
Elimina = ""
End If
Else
Open Rta For Append As #1
Write #1, Remitente0, Remitente1, Fecha, Asunto
Close
End If
End If

Next Item

Kill Rta
MsgBox Contador & " mensajes eliminados.", vbInformation

End Sub