Excel-VBA : Send Unique Images Embedded to Mail Body, With Every Mail From MS Outlook using Excel.

Many a times you need a scenario when you want to send a mail on the daily basis and every new mail contain new image embedded to the mail body, say for example you want to send Good morning message with new image every day.

I would recommend that you must read Send a Simple Mail From MS Outlook Using Excel and how to send Embedded to the mail body from MS Outlook using Excel to understand the basics first if you are new to this.

So how would you do that, there are many different ways to accomplish this, the strategy which I have used here is

Store all the Images in a folder.
First time you run your macro, the program will connect to the image folder, take the first image and use it and mark that image as used in our excel.
Next time when you run the macro, it will see which image is not marked as used, use that. see this picture below.

Complete Code:

Sub sumit()
Dim mainWB As Workbook
Dim SendID
Dim CCID
Dim Subject
Dim Body
Dim olMail As MailItem

Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(olMailItem)
Set Doc = olMail.GetInspector.WordEditor
Dim oAttach As Outlook.Attachment

Set mainWB = ActiveWorkbook

SendID = mainWB.Sheets("Mail").Range("B1").Value
CCID = mainWB.Sheets("Mail").Range("B2").Value
Subject = mainWB.Sheets("Mail").Range("B3").Value
Body = mainWB.Sheets("Mail").Range("B4").Value
With olMail
.To = SendID
If CCID <> "" Then
.CC = CCID
End If
.Subject = Subject
strFilepath = AddImage(strFile)
MsgBox strFile & "   " & strFilepath
'add the image in hidden manner, position at 0 will make it hidden
.Attachments.Add strFilepath, olByValue, 0
'Now add it to the Html body using image name
'change the src property to 'cid:your image filename'
'it will be changed to the correct cid when its sent.
.HTMLBody = .HTMLBody & "<br><B>Todays Image:</B><br>" _
& "<img src='cid:" & Trim(strFile) & "'" & "width='500' height='200'><br>" _
& "<br>Best Regards, <br>Sumit</font></span>"
.Display
.Send
End With

MsgBox ("you Mail has been sent to " & SendID)

End Sub
Function AddImage(strFile)
Dim mainWorkBook As Workbook
Set mainWorkBook = ActiveWorkbook
Dim blnFound
Folderpath = mainWorkBook.Sheets("Setting").Range("H3").Value
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files

For Each fls In listfiles
For i = 1 To NoOfFiles + 5
rowNo = i + 1
cellVal = mainWorkBook.Sheets("Setting").Range("A" & rowNo).Value
If (cellVal <> "") Then
' checking if image is used
If (StrComp(Trim(cellVal), Trim(fls.Name), vbTextCompare) = 0) Then
Exit For
End If
Else
'if you are here, that means you have found the new image to use
mainWorkBook.Sheets("Setting").Range("A" & rowNo).Value = Trim(fls.Name)
strCompFilePath = Folderpath & "\" & Trim(fls.Name)
AddImage = strCompFilePath
strFile = Trim(fls.Name)
blnFound = True
Exit For
End If
Next
If (blnFound) Then
Exit For
End If
Next
mainWorkBook.Save
End Function

Send Mail

Different Images in New Mail

automate 45 microsoft outlook 8