Comprobar entrega y/o lectura de correo en Outlook 2003

[jomapaca]

Que tal!!! Trataré de ser muy explicito en el problema que me aqueja.

Estoy generando una macro en excel que envía correos electrónicos con un archivo adjunto. Este primer proceso ya lo hace. Todo funciona sin problema debido a que todo estos envíos se realizan a usuarios de la misma empresa y no hay mayor problema.

El verdadero problema comienza aqui: Es imprescindible que valide si el usuario recibió y leyó el correo y generar un reporte de esto. Sé que el envío del correo no es garantía de su lectura, pero eso es precisamente lo que tengo que validar.

He activado la confirmación de entrega y lectura mediante el siguiente bloque de codigo:

ElMensaje.Subject = "TARIFICADOR " & mes_año
ElMensaje.BodyFormat = olFormatHTML
ElMensaje.HTMLBody = txtHTML
ElMensaje.Attachments.Add Nombre, 1, 1
ElMensaje.DELETEAFTERSUBMIT = True
ElMensaje.ReadReceiptRequested = True 'Se solicita confirmación de lectura
ElMensaje.OriginatorDeliveryReportRequested = True 'Se origina reporte de entrega
ElMensaje.IMPORTANCE = 2
ElMensaje.send

Esto funciona correctamente. A mi bandeja de entrada llegan los correos que confirman la entrega y la lectura.

Ahora lo que procede es generar ese reporte (un simple listado) en Excel. La primera parte la hago mediante la validación del SUBJECT, uso el método RESTRICT para restringir los correos que concuerden con el subject indicado (una cadena que siempre será la misma, sólo cambia el mes y el año). Tambien funciona correctamente y puedo obtener asunto y cuerpo del mail, sin embargo, no puedo obtener el nombre del usuario al cual se le envió el correo. Me envía un error que me dice "Tipo de datos no coinciden". Me queda claro a que se debe, pero no logro entender como debería hacerlo entonces si se supone que el objeto ITEMS en su método ITEM me permite obtener esto. Anexo el código que describo:


Sub ChecaEntrega()

Dim i As Integer
Dim F As Integer

Dim sAsunto As String
Dim sBody As String
Dim sUsuario As String

Dim sCriterio As String
Dim fecha As String

Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myFolder As Outlook.MAPIFolder
Dim myLecturas As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myRestrictItems As Outlook.Items
Dim myItem As Outlook.MailItem


fecha = InputBox("Indique mes y año a verificar")
If fecha <> "" Then
sCriterio = "TARIFICADOR " & UCase(fecha)
Else
sCriterio = "TARIFICADOR "
End If

Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)

Set myItems = myFolder.Items
Set myRestrictItems = myItems.Restrict("[Subject] = '" & sCriterio & "'")


For i = myRestrictItems.Count To 1 Step -1
myRestrictItems(i).Move myFolder.Folders("Lecturas")
Next

Set myLecturas = myFolder.Folders("Lecturas")


Set myItems = myFolder.Folders("Lecturas").Items

'VERIFICA PRIMERO LA ENTREGA DE LOS CORREOS
For i = myItems.Count To 1 Step -1
Set myItem = myItems.Item(i) 'AQUI SE GENERA EL ERROR
sAsunto = myItems.Item(i).Subject 'PERO ESTO FUNCIONA PERFECTO
If sAsunto = "Entregado: " & sCriterio Then
sBody = myItems.Item(i).Body
'sUsuario = myItems.Item(i)
ActiveWorkbook.Sheets("ENVIADOS").Activate
Columns("A:A").Select
Selection.Find(What:="" & sUsuario & "", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate

F = Selection.Row
Range("B" & F).Value = myItem(i).ReceivedTime
End If
Next




End Sub

Agradeceré muchisimo cualquier ayuda que puedan ofrecer. Esto me urge de verdad, me pongo en sus manos.

Gracias de antemano, saludos a todos!

[jomapaca]

Ok, como no he recibido respuestas y a mi me urge esto, tuve que resolverlo creando una función que obtiene el nombre del usuario desde el correo de confirmación de entrega.

Ahora sólo necesito obtener la fecha de entrega del correo, por lo tanto sigo pidiendo sugerencias y su apoyo.

Anexo el código de la función con la que limpio el contenido del correo de confirmación de entrega para apoyo y referencia:


Function BuscaUsuario(sCuerpo As String, sAsunto As String) As String

Dim sResul As String
Dim sUser As String

'Se va limpiando el body del mensaje para dejar solo el usuario y poder localizarlo en la lista de usuarios generada en Excel

sResul = Replace(sCuerpo, "El mensaje se ha entregado a los siguientes destinatarios:", "")
sResul = Replace(sResul, "HYPERLINK", "")
sResul = Replace(sResul, "mailto:", "")
sResul = Replace(sResul, "dominio.com", "") 'Si es un usuario con correo externo
sResul = Replace(sResul, "email.", "") 'Si es un usuario con correo interno
sResul = Replace(sResul, "@", "")
sResul = Replace(sResul, sAsunto, "")
sResul = Replace(sResul, "Enviado por Microsoft Exchange Server 2007", "")
sResul = Replace(sResul, "_", "")
sResul = Replace(sResul, " ", "")
sResul = Replace(sResul, "Asunto:", "")
sResul = Replace(sResul, vbCrLf, "")

sResul = Trim(sResul)

'Busca la cadena que queda entre comillas la cual representa el usuario
For i = 1 To Len(sResul)

If Mid(sResul, i, 1) <> Chr(34) And i > 1 Then
sUser = sUser & Mid(sResul, i, 1)
ElseIf Mid(sResul, i, 1) = Chr(34) And i > 1 Then
Exit For
End If

Next

BuscaUsuario = Trim(sUser)

End Function

[jomapaca]

Ok, solo por informar a los que hayan leído esto, les comento que he resuelto el problema:

Todo el problema radicaba en el uso correcto de los objetos. Yo estaba un poco confundido con la situación de las propiedades del objeto MailItem. Tratando incorrectamente de usar el método Item del objeto Items como si usara las mismas propiedades que el MailItem. (¿he sido claro? Espero que si).

En fin, todo se resolvió simplemente asignando el objeto MailItem el Item correspondiente mediante el objeto MAPIFolder de Outlook.

Anexo código para quien lo pueda usar:

NOTA IMPORTANTE: DEBEN SER MUY DETALLISTAS AL MIRAR ESTE CODIGO YA QUE CAMBIA PRACTICAMENTE SOLO 2 LINEAS EN EL.

Sub ChecaEntrega()
Dim i As Integer
Dim F As Integer

Dim sAsunto As String
Dim sBody As String
Dim sUsuario As String

Dim sCriterio As String
Dim sFechaEnt As String
Dim fecha As String

Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myFolder As Outlook.MAPIFolder
Dim myLecturas As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myRestrictItems As Outlook.Items
Dim myItem As Outlook.MailItem

fecha = InputBox("Indique mes y año a verificar")
If fecha <> "" Then
sCriterio = "TARIFICADOR " & UCase(fecha)
Else
sCriterio = "TARIFICADOR "
End If

Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)

Set myItems = myFolder.Items
Set myRestrictItems = myItems.Restrict("[Subject] = '" & sCriterio & "'")


For i = myRestrictItems.Count To 1 Step -1
myRestrictItems(i).Move myFolder.Folders("Lecturas")
Next

Set myLecturas = myFolder.Folders("Lecturas")


Set myItems = myFolder.Folders("Lecturas").Items

'VERIFICA PRIMERO LA ENTREGA DE LOS CORREOS
For i = myItems.Count To 1 Step -1
sAsunto = myItems.Item(i).Subject
Set myItem = myFolder.Items(i) 'ESTA ES LA LINEA QUE MARCA EL CAMBIO
If sAsunto = "Entregado: " & sCriterio Then
If myItem Is Nothing Then GoTo Siguiente
sBody = myItems.Item(i).Body
sUsuario = BuscaUsuario(sBody, sCriterio)
sFechaEnt = Format(myItem.ReceivedTime, "dd/mm/yyyy")
ActiveWorkbook.Sheets("ENVIADOS").Activate
Columns("A:A").Select
Selection.Find(What:="" & sUsuario & "", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
F = ActiveCell.Row
Range("B" & F).Value = sFechaEnt

End If
Siguiente:
Next

End Sub