Использование Outlook 2016 VBA, сохранение вложения при отправке с использованием SMTP/CDO

Я хотел бы избежать сохранения вложения из исходного сообщения Outlook на локальный диск, а затем повторно прикрепить его к сообщению SMTP. Тело сообщения воссоздается для сообщения SMTP, которое работает нормально.

Sub ForwardEmail(myEmail As Outlook.MailItem) 'subroutine called from Outlook rule, when new incoming email message arrives
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x0076001E"
Set objSMTPMail = CreateObject("CDO.Message") 'needed to send SMTP mail
Set objConf = CreateObject("CDO.Configuration") 'needed for SMTP configuration

Set objFlds = objConf.Fields 'used for SMTP configuration

'Set various parameters and properties of CDO object

objFlds.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2     
objFlds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtpout.test.com" 'define SMTP server
objFlds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 'default port for email

objFlds.Update

objSMTPMail.Configuration = objConf

If myEmail.SenderEmailType = "EX" Then
  objSMTPMail.From = myEmail.Sender.GetExchangeUser.PrimarySmtpAddress
Else
  objSMTPMail.From = myEmail.SenderEmailAddress 'takes email address from   the original email and uses it in the new SMTP email
 objAttachments = myEmail.Attachments  ' I believe this is how to get the attachments

End If

objSMTPMail.Subject = myEmail.Subject 'use the subject from the original email message for the SMTP message
objSMTPMail.HTMLBody = myEmail.HTMLBody 'myEmail.HTMLBody is necessary to retain Electronic Inquiry Form formatting
objSMTPMail.To = "[email protected]"
objSMTPMail.AddAttachment objAttachments ' tried to add attachment
'send the SMTP message via the SMTP server
objSMTPMail.Send




'Set all objects to nothing after sending the email

Set objFlds = Nothing
Set objConf = Nothing
Set objSMTPMail = Nothing

End Sub

outlook vba cdo.message
person user9308240    schedule 21.11.2018    source источник
comment
Я думал, что следующие строки в коде будут работать, но это не так. objAttachments = myEmail.Attachments, а затем SMTPMail.AddAttachment objAttachments Прикрепляет только пустой файл BIN (расширение файла — BIN).   -  person user9308240    schedule 21.11.2018
comment
См. этот ответ (это ASP , но должен дать суть) для представления о том, как добавить вложение, которое не из файла. Обратите внимание, что вам нужно будет найти кодировщик Base64 (или написать его — это несложно).   -  person Comintern    schedule 22.11.2018
comment
@user9308240 user9308240 Я нигде не вижу объявления objAttachments. Если это должна быть ссылка на объект, вам может потребоваться 1. Dim его как объект и 2. вам может потребоваться изменить objAttachments = myEmail.Attachments на Set objAttachments = myEmail.Attachments. Чтобы избежать подобных ошибок, поместите Option Explicit вверху модуля/до того, как ваш код сможет помочь.   -  person chillin    schedule 22.11.2018
comment
Спасибо за информацию. Я проведу тест сегодня вечером и опубликую обновление завтра утром. Если это имеет значение, вложения могут быть любыми, такими как ODF, DOCX, JPEG и т. д. Я очень мало работал с VBA и определенно не с Outlook, поэтому для меня это новая территория.   -  person user9308240    schedule 26.11.2018
comment
Я обнаружил, что проще всего сохранить файл(ы) локально, а затем снова прикрепить их к SMTP-сообщению.   -  person user9308240    schedule 02.12.2018

Ответы (1)


arrow_upward
0
arrow_downward

Вот мое решение. Это работает для моей ситуации.

Sub ForwardEmail(myEmail As Outlook.MailItem) 'subroutine called from Outlook rule, when new incoming email message arrives

On Error GoTo Resetvar
Set objSMTPMail = CreateObject("CDO.Message") 'needed to send SMTP mail
Set objConf = CreateObject("CDO.Configuration") 'needed for SMTP configuration

Set objFlds = objConf.Fields 'used for SMTP configuration

'Set various parameters and properties of CDO object

objFlds.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'cdoSendUsingPort
objFlds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtpout.test.com" 'define SMTP server
objFlds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 'default port for email

objFlds.Update

objSMTPMail.Configuration = objConf

'EX value is an Exchange mailbox locally
If myEmail.SenderEmailType = "EX" Then
    objSMTPMail.From = myEmail.Sender.GetExchangeUser.PrimarySmtpAddress
Else
    objSMTPMail.From = myEmail.SenderEmailAddress 'takes email address from the original email and uses it in the new SMTP email
End If
Dim i As Integer
i = -1
Dim arrAtmt() As String
Dim FileName As String
For Each Atmt In myEmail.Attachments
    FileName = "C:\temp\" & myEmail.EntryID & "." & Atmt.FileName
    Atmt.SaveAsFile FileName
    i = i + 1
    ReDim Preserve arrAtmt(i)
    arrAtmt(i) = FileName
Next Atmt

    objSMTPMail.Subject = myEmail.Subject 'use the subject from the original email message for the SMTP message
    objSMTPMail.HTMLBody = myEmail.HTMLBody 'myEmail.HTMLBody is necessary to retain Electronic Inquiry Form formatting
    objSMTPMail.To = "[email protected]"

    If i > -1 Then
        For counter = 0 To i
            objSMTPMail.AddAttachment arrAtmt(counter)
        Next
    End If
    objSMTPMail.Send

Erase arrAtmt

Resetvar:

Set objFlds = Nothing
Set objConf = Nothing
Set objSMTPMail = Nothing

End Sub
person user9308240    schedule 02.12.2018