Картинка из Excel в Outlook - VB

Формулировка задачи:

Уважаемы форумчане, доброго времени суток! Пробую написать макрос, который через Excel, отправляет электронное сообщение через Outlook. В качестве подписи используется картинка. После долгих поисков и методов описанных на разных форумах понял, что лучший вариант, это использовать в теле письма htmlBody тэги. В итоге, вроде и текст пишется и картинка вставляется. Но есть одна проблема, если письмо отправлять используя методо DISPLAY, то все хорошо (отправляется и текст и картинка), если использовать SEND, то уходит только текст, а самой картинки нет. Пробовал ставить пере отправкой письма и после очистки сообщения таймаут на отправку, думая, что возможно при отправке не успевает подгрузиться картинка. Если отправить 2 письма,то можно и через DISPLAY, а если это 1000 писем!!.Вот код:
Sub SendMail()
 
Dim OutApp As Object
Dim OutMail As Object
Dim htmlBody As String
 
picfile$ = "C:\Users\image002.gif"
 
    htmlBody = "<body><font face=Arial color=#000080 size=2></font>" & _
                "<br>" & "1. çëГ*ГІГ*" & "<br>" & "<br><br><img width=290 height=150 alt='' hspace=0 src='" & picfile$ & " ' align=baseline order=0>&nbsp;</body>"
            
        Application.ScreenUpdating = False
        Set OutApp = CreateObject("Outlook.Application")   'Г§Г*ГЇГіГ±ГЄГ*ГҐГ¬ Outlook Гў ñêðûòîì ðåæèìå
            OutApp.Session.Logon ("test@mail.ru")
        On Error GoTo cleanup 'åñëè Г*ГҐ Г§Г*ïóñòèëñÿ - âûõîäèì
                
        Set OutMail = OutApp.CreateItem(0)   'ñîçäГ*ГҐГ¬ Г*îâîå ñîîáùåГ*ГЁГҐ
        On Error Resume Next    'Г§Г*ïîëГ*ГїГҐГ¬ ïîëÿ ñîîáùåГ*ГЁГї
                 
        With OutMail
            .To = E_mail 'Count
            .Subject = "ГІГҐГ±ГІ"
            .BodyFormat = 2
            .htmlBody = htmlBody
            .Send
        End With
 
        On Error GoTo 0
                
        Application.Wait (Now + TimeValue("0:00:01")) 'Г*Г* 1 Г±ГҐГЄ
        Set OutMail = Nothing
cleanup:
        Set OutApp = Nothing
        Application.ScreenUpdating = True
End Sub

Код к задаче: «Картинка из Excel в Outlook - VB»

textual
dim cdoMessage, cdoConfig, sch
 
sch = "http://schemas.microsoft.com/cdo/configuration/"
Set cdoConfig = Server.CreateObject("CDO.Configuration")
set cdoMessage = Server.CreateObject("CDO.Message")
 
With cdoConfig.Fields
  .Item(sch & "sendusing") = 2 ' cdoSendUsingPort
  .Item(sch & "smtpserver") = "<your SMTP server>"
  .Item(sch & "sendusername") = "<SMTP username>"
  .Item(sch & "sendpassword") = "<SMTP password>"
  .update
End With
 
Set cdoMessage.Configuration = cdoConfig
cdoMessage.From = "test@test.com"
cdoMessage.ReplyTo = "test@test.com"
cdoMessage.To = "<your test email address>"
cdoMessage.Subject = "Test subject"
cdoMessage.HtmlBody = "<html><body><img src=""cid:myimage.gif""/></body></html>" & vbCrLf
 
Set objBP = cdoMessage.AddRelatedBodyPart("c:\head-logo.gif", "myimage.gif", CdoReferenceTypeName)
objBP.Fields.Item("urn:schemas:mailheader:Content-ID") = "<myimage.gif>"
objBP.Fields.Update
 
cdoMessage.Send

9   голосов, оценка 3.667 из 5


СОХРАНИТЬ ССЫЛКУ