elencare i destinatari di una mail

[Ammammata]

ho adattato una breve routine che a ogni arrivo di mail mi stampa a video
(nella finestra "immediata") l'oggetto e il mittente, controlla se arriva
da un particolare dominio, confronta i destinatari con alcuni indirizzi ed
eventualmente (da fare) la inoltra a quelli che non erano presenti

sostanzialmente č corretta, ma ci sono due punti:
- se ricevo piů di una mail mi elabora la prima e poi se ne esce
- la parte relativa all'inoltro č mancante e non ho ancora idea di come
farla, spero di trovare suggerimenti sul sito indicato qui sotto





' Processing Incoming E-mails with Macros
' https://www.slipstick.com/developer/processing-incoming-e-mails-with-
macros/

Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objNewMailItems As Outlook.Items

Private Sub Application_Startup()
Dim objMyInbox As Outlook.MAPIFolder

Set objNS = Application.GetNamespace("MAPI")
Set objMyInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objNewMailItems = objMyInbox.Items
Set objMyInbox = Nothing
End Sub

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

Dim objNS As Outlook.NameSpace
Dim objEmail As Outlook.MailItem
Dim strIDs() As String
Dim intX As Integer
Dim SenderDomainName As String

SenderDomainName = "@" ' per le prove lascio passare tutto

strIDs = Split(EntryIDCollection, ",")
For intX = 0 To UBound(strIDs)
Set objNS = Application.GetNamespace("MAPI")
Set objEmail = objNS.GetItemFromID(strIDs(intX))
Debug.Print "Message subject : " & objEmail.Subject
Debug.Print "Message sender : " & objEmail.SenderName & " (" &
objEmail.SenderEmailAddress & ")"
If InStr(1, objEmail.SenderEmailAddress, SenderDomainName) > 0 Then
ListRecipients objEmail ' ...and forward
End If
Next ' nota: dopo aver elaborato la prima mail se ne esce, non c'č un Next
Set objEmail = Nothing
End Sub


' list recipients
Private Sub ListRecipients(Mail As Outlook.MailItem)
On Error Resume Next
Dim Ns As Outlook.NameSpace
Dim Recipients As Outlook.Recipients
Dim Recip As Outlook.Recipient
Dim Folder As Outlook.MAPIFolder

Dim objEmail As Outlook.MailItem

' init variables for recipients
Dim FP, BS, OM, MP As Boolean
Dim RecipientList As String

FP = True
BS = True
OM = True
MP = True


Set Recipients = Mail.Recipients
For Each Recip In Recipients
Debug.Print "Recipient : " & Recip.Name & " (" & Recip.Address & ")"
If Recip.Address = "f...@dittadelcliente.com" Then FP = False
If Recip.Address = "b...@dittadelcliente.com" Then BS = False
If Recip.Address = "o...@dittadelcliente.com" Then OM = False
If Recip.Address = "m...@dittadelcliente.com" Then MP = False
Next

If Not( FP Or BS Or OM Or MP ) Then Exit Sub ' all of them already got a
copy

' prepare list to forward to
RecipientList = ""
If FP Then RecipientList = RecipientList + "f...@dittadelcliente.com; "
If BS Then RecipientList = RecipientList + "b...@dittadelcliente.com; "
If OM Then RecipientList = RecipientList + "o...@dittadelcliente.com; "
If MP Then RecipientList = RecipientList + "m...@dittadelcliente.com; "
If Len(RecipientList) = 0 Then Exit Sub ' not strictly necessary, just an
additional test; all of them already got a copy

Debug.Print "Forward to : " & RecipientList

' nota: da fare: inoltrare ai destinatari mancanti

End Sub


--
/-\ /\/\ /\/\ /-\ /\/\ /\/\ /-\ T /-\
-=- -=- -=- -=- -=- -=- -=- -=- - -=-
........... [ al lavoro ] ...........

[Ammammata]

Il giorno Mon 08 Nov 2021 05:22:15p, *Ammammata* ha inviato su
microsoft.public.it.office.outlook il messaggio
news:XnsADDCB0B62F127am...@127.0.0.1. Vediamo cosa ha
scritto:

> - la parte relativa all'inoltro è mancante


ho trovato questo, funziona quasi tutto... nel senso che predispone
correttamente l'invio con i nuovi destinatari ma perdo completamente il
corpo del messaggio originale :/

da un altro account mi mando una mail con oggetto, due righe di testo, un
allegato

quando outlook riceve la mail verifica il mittente, controlla i destinatari
già in copia,poi fa questo:


' forward mail
Dim objForward As Outlook.MailItem

'see if it is running - si toglie quando funziona
MsgBox Mail.Subject

Set objForward = Mail.Forward ' dovrebbe copiare *tutta* la mail

With objForward

.Subject = Mail.Subject ' ok, non si tocca

' queste due non funzionano, ho anche provato a disabilitarle e a eseguirle
separatamente
.Body = Mail.Body
.HTMLBody = Mail.HTMLBody

' questo funziona
If FP Then .Recipients.Add ("f...@dittadelcliente.com")
If BS Then .Recipients.Add ("b...@dittadelcliente.com")
If OM Then .Recipients.Add ("o...@dittadelcliente.com")
If MP Then .Recipients.Add ("m...@dittadelcliente.com")
.Recipients.ResolveAll

' sostituisco .Send con .Display per debug
.Display
'.Send

End With

End Sub


come scrivevo all'inizio la mail viene creata correttamente con l'oggetto e
i destinatari, la mia firma prima dello header originale, ma perde tutta la
parte del corpo, allegati compresi

ho provato sia .Body che .HTMLBody, niente

c'è sicuramente un errore, ma non lo vedo :/

grazie