Embedding images in Outlook 2010 with VBA [Archive]

JasonCollier

01-29-2015, 01:39 AM

Hi all,

I'm new to coding and am trying to automate sending emails from my access database. I've set up a module that sends out a HTML formatted email which works great, except the images don't show up in the recipients email - the images are included as attachments and where they are supposed to be in the email there are broken image icons.

I have searched for help on embedding images in Outlook, but have had no luck getting it to work. Can anyone show me how to fix my code below so that it will embed images instead of attaching them?

Many thanks!
Jason

Option Compare Database

Option Explicit

Sub SendMessages(Optional AttachmentPath)

Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachments
Dim myAttach As Outlook.Attachment
Dim TheAddress As String

Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("qry_Members")
MyRS.MoveFirst

' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

Do Until MyRS.EOF
' Create the e-mail message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
TheAddress = MyRS![WorkEmail]

With objOutlookMsg
' Add the To recipients to the e-mail message.
Set objOutlookRecip = .Recipients.Add(TheAddress)
objOutlookRecip.Type = olTo

' Add the CC recipients
Set objOutlookRecip = .Recipients.Add("email address")
objOutlookRecip.Type = olCC

' Set the from address.
objOutlookMsg.SentOnBehalfOfName = "email address"

' Set the Subject, the Body, and the Importance of the e-mail message.
.Subject = "subject"

Set objOutlookAttach = objOutlookMsg.Attachments
Set myAttach = objOutlookAttach.Add("C:\Users\collj\Desktop\database\sig.jpg", olByValue, 0)
Set myAttach = objOutlookAttach.Add("C:\Users\collj\Desktop\database\banner.jpg", olByValue, 0)
objOutlookMsg.Close olSave
objOutlookMsg.Save

objOutlookMsg.BodyFormat = olFormatHTML

.HTMLBody = "<html><body>"

.HTMLBody = .HTMLBody & "<table align=""center"" style=""width:580px; margin:0 auto; padding:0; border:0"" cellspacing=""0"" cellpadding=""0"">"

.HTMLBody = .HTMLBody & "<tr><td style=""background-color:#46819b; font-family:Arial,Sans-serif; font-size:12px; color:white; margin:0;padding:10px"">Title</td></tr>"

.HTMLBody = .HTMLBody & "<tr><td><img src=""cid:banner.jpg""></td></tr><tr><td style=""padding:20px 10px"">"

.HTMLBody = .HTMLBody & "Dear " & MyRS![FirstName] & ","

.HTMLBody = .HTMLBody & "Content goes here"

.HTMLBody = .HTMLBody & "Yours sincerely,<img src=""cid:sig.jpg"">"

.HTMLBody = .HTMLBody & "Name</td></tr>"

.HTMLBody = .HTMLBody & "</table></body></html>"

.Importance = olImportanceNormal 'Normal importance

objOutlookMsg.Save

' Resolve the name of each Recipient.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
.Send
End With
MyRS.MoveNext
Loop
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub

gmayor

01-29-2015, 02:50 AM

I don't work in Access, but the business of creating e-mails using Outlook is pretty similar across the Office products, so if I was doing this I would be inclined to use the Outlook Inspector to edit the message body directly. It is then very similar to working in Word e.g.

Public Sub CreateEmail()
Dim olApp As Object
Dim olMail As Object ' Outlook.MailItem
Dim olInspector As Object ' Outlook.Inspector
Dim olAttach As Object
Dim wdDoc As Object ' Word.Document
Dim wdRange As Object ' Word.Range

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
If olApp Is Nothing Then Exit Sub
On Error GoTo 0

Set olMail = olApp.CreateItem(0)

With olMail
.to = "someone@somewhere.com"
.Subject = "This is the subject"
Set olAttach = olMail.Attachments
olAttach.Add "C:\Path\example.txt"
Set olInspector = .GetInspector
Set wdDoc = olInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.Text = "Dear Recipient" & vbCr & vbCr & _
"Message content" & vbCr & vbCr
wdRange.Collapse 0
wdRange.InlineShapes.AddPicture Filename:= _
"C:\Path\Filename.jpg", _
LinkToFile:=False, _
SaveWithDocument:=True
wdRange.End = wdRange.End + 2
wdRange.Collapse 0
wdRange.Text = vbCr & "Yours sincerely" & vbCr
wdDoc.Range.Font.name = "Arial"
wdDoc.Range.Font.Size = 12
.Display ' This line is required.
.Send
End With
lbl_Exit:
Exit Sub
End Sub