Как удалить определенного получателя из всех шаблонов электронной почты в каталоге на моем рабочем столе?

#vba #outlook

Вопрос:

У меня есть папка каталога (папка на рабочем столе) сообщений Outlook (.msg) , которые я использую в качестве шаблонов для создания электронных писем.

В этой папке может быть 500 электронных писем. Мне нужно удалять определенный адрес электронной почты из каждого из этих писем иногда раз в месяц.

 Sub test()

Dim m As MailItem 'object/mail item iterator
Dim recip As Recipient 'object to represent recipient(s)
Dim email As Long

Set Remove = m.Remove

email = InputBox("Please enter the e-mail address you wish to remove")
answer = MsgBox("Are you sure you want to delete this e-mail?", vbYesNo   vbCritical, "Delete?")
If answer = vbYes Then

For Each m In Application.ActiveExplorer.Selection
If m.Class = olMail Then
Set Remove = m.Recipients.Remove(email)

End If

m.Save
End If

Next

End Sub

Как мне это сделать с помощью VBA?

Если электронное письмо имеет johndoe@gmail.com , я ожидаю, что это электронное письмо будет удалено после того, как я выполню этот код во всех TO, CC, BCC и т.д.

Ответ №1:

Попробуйте это

 Option Explicit
Public Sub Example()
    Dim Path As String
        Path = "C:Temp"

    Dim msgFile As String
        msgFile = Dir(Path amp; "*.msg")

    Dim msg As Object
    Do While Len(msgFile) > 0
        Set msg = Application.Session.OpenSharedItem(Path amp; "" amp; msgFile)
        Debug.Print msg.Subject

            GetSMTPAddress msg

        msgFile = Dir
    Loop

    Set msg = Nothing
End Sub

Private Sub GetSMTPAddress(Mail As Outlook.MailItem)
    Dim pa As Outlook.PropertyAccessor

    Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

    Dim i As Long
    For i = Mail.Recipients.Count To 1 Step -1
        DoEvents
        Set pa = Mail.Recipients(i).PropertyAccessor

        If LCase(pa.GetProperty(PR_SMTP_ADDRESS)) = _
           LCase("0m3r@Email.com") Then
                Mail.Recipients.Remove (i)
                Debug.Print pa.GetProperty(PR_SMTP_ADDRESS)
                Mail.Save
        End If

    Next
End Sub

Обязательно обновите адрес электронной почты 0m3r@Email.com и путь к папке Path = "C:Temp"

1. Вы БОСС. Спасибо. Я добавил «При возобновлении ошибки» рядом с вашим оператором If. Похоже, что строка «Const PR_SMTP_ADDRESS as String» вернет ошибку, если некоторые электронные письма отсутствуют в Microsoft Exchange.

Ответ №2:

Вызовите Application.Session.OpenSharedItem для каждого файла MSG, удалите получателя, вызовите MailItem.Save .