Mail merge to email with personalized attachments and message (picture and text) - vba

Question

I am trying to get the personalized message working. I have difficulty in sending pictures and text while preserving the text formatting (bold, italic,...).
I read on a related subject on this website regarding a similar problem (Preserve text format when sending the content of a word document as the body of an email,). It helped me to get started.
Code I am using:
Sub emailmergewithattachments_2()
Dim Source As Document, Maillist As Document, wdDoc As Document
Dim Datarange As Range
Dim wdRange As Range
Dim i As Long, j As Long
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim Insp As Outlook.Inspector
Dim MySubject As String, Message As String, Title As String
'The source document is Word document that contains the personnalised
'letters sent to the recipients
Set Source = ActiveDocument
' Check if Outlook is running. If it is not, start Outlook
On Error Resume Next
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
' Open the catalog mailmerge document
With Dialogs(wdDialogFileOpen)
.Show
End With
'The Maillist is a 2 column table containing the email adress and the second column
'contains the path and the name of the file to be joined with the email
Set Maillist = ActiveDocument
' Show an input box asking the user for the subject to be inserted into the email messages
Message = "Enter the subject to be used for each email message." ' Set prompt.
Title = " Email Subject Input" ' Set title.
' Display message, title
MySubject = InputBox(Message, Title)
' Iterate through the Sections of the Source document and the rows of the catalog mailmerge document,
' extracting the information to be included in each email.
For j = 1 To Source.Sections.Count - 1
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.Subject = MySubject 'subject line
'reading the first column of the maillist (the email)
Set Datarange = Maillist.Tables(1).Cell(j, 1).Range
Datarange.End = Datarange.End - 1
.To = Datarange 'recipient's email
'joining the personalised attachements to each recipient
For i = 2 To Maillist.Tables(1).Columns.Count
Set Datarange = Maillist.Tables(1).Cell(j, i).Range
Datarange.End = Datarange.End - 1
.Attachments.Add Trim(Datarange.Text), olByValue, 1
Next i
'Obtain the Inspector for this Email
Set Insp = oItem.GetInspector
'Obtain the Word document for the Inspector
Set wdDoc = Insp.WordEditor
'Use the Range object to insert text
Set wdRange = wdDoc.Range(0, wdDoc.Characters.Count)
wdRange.InsertAfter ("Text inserted") 'for testing only (to check if it really working)
'Word document containing the text and the images
Windows("lettres.docx").Activate
Selection.WholeStory
'*******************************************************************************
'Problematic part: trying to paste the selection into wdDoc while preserving the formatting
'and the entire content of the document of the file "lettres.docx"
'...missing code
'********************************************************************************
.Send
End With
Set oItem = Nothing
Next j
Maillist.Close wdDoNotSaveChanges
' Close Outlook if it was started by this macro.
If bStarted Then
oOutlookApp.Quit
End If
MsgBox Source.Sections.Count - 1 & " messages have been sent."
'Clean up
Set oOutlookApp = Nothing
End Sub

Answer 1

I took a different approach. I did a regular mail merge in MS Word and sent the mail in HTML format which keeps all the formatting and the graphics. Then in Outlook, i created a macro which adds the attachments when each email is sent. An Excel worksheet contains the path of files to be joined for each email.
==> important note: Outlook must be opened (application loaded) before sending the data from Word to Outlook or else the emails will likely get stuck in the outbox and as a result the macro will simply not work (emails will be sent but with no attachments)
Code in a ThisOutlookSession:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If Item.Class = olMail Then
Dim objCurrentMessage As MailItem
Set objCurrentMessage = Item
If UCase(objCurrentMessage.Subject) Like "PUBLIIDEM*" Then
On Error Resume Next
'Pour ajouter la même PJ à tous
Dim i As Long
i = 0
If publipostagePJ <> "" Then
While publipostagePJ(i) <> "fin"
objCurrentMessage.Attachments.Add Source:=publipostagePJ(i)
i = i + 1
Wend
End If
'On supprime le terme PUBLIIDEM du sujet
objCurrentMessage.Subject = Replace(objCurrentMessage.Subject, "PUBLIIDEM ", "")
ElseIf UCase(objCurrentMessage.Subject) Like "PUBLIPERSO*" Then
If Chemin = "" Then
Chemin = InputBox("Entrez le chemin d'accès et le nom du fichier:", "Envoies personnalisés")
On Error Resume Next
Set oExcelApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set oExcelApp = CreateObject("Excel.Application")
bStarted = True
End If
Workbooks.Open Chemin
Set oWB = Excel.ActiveWorkbook
oWB.Sheets("fichiers").Select
DerniereLigne = Cells(Rows.Count, 1).End(xlUp).Row
'DerniereColonne = Cells(1, Columns.Count).End(xlToLeft).Column
End If
For i = 1 To DerniereLigne
If Cells(i, 1) = objCurrentMessage.To Then
For j = 2 To 5
FichierJoin = Cells(i, j)
If Len(FichierJoin) > 0 Then objCurrentMessage.Attachments.Add Source:=FichierJoin
Next j
End If
Next i
'On supprime le terme PUBLIPERSO du sujet
objCurrentMessage.Subject = Replace(UCase(objCurrentMessage.Subject), "PUBLIPERSO ", "")
End If
Set objCurrentMessage = Nothing
End If
End Sub
Private Sub Application_Quit()
If bStarted Then
oExcelApp.Quit
End If
Set oExcelApp = Nothing
Set oWB = Nothing
End Sub
Code in a module
Public publipostagePJ As Variant
Public oExcelApp As Excel.Application
Public oWB As Excel.Workbook
Public DerniereLigne As Long
Public DerniereColonne As Long
Public bStarted As Boolean
Public FichierJoin, Chemin As String
Sub setPublipostage()
On Error Resume Next
If publipostagePJ(0) = "" Then publipostagePJ = Array("fin", "fin", "fin", "fin", "fin", "fin", "fin", "fin", "fin", "fin")
While publipostagePJ(i) <> "fin"
contenu = contenu & vbCr & publipostagePJ(i)
i = i + 1
Wend
If contenu = "" Then contenu = "vide"
modifier = MsgBox(contenu & vbCr & "Voulez vous modifier les fichiers ?", vbYesNo, "Fichiers paramétrés")
If modifier = vbYes Then
For i = 0 To 9
If i > 0 Then encore = MsgBox("un autre ?", vbYesNo)
quest:
If encore <> vbNo Then
PJ = InputBox("Emplacement du fichier joint au PUBLIPOSTAGE?", _
"Paramétrage du PUBLIPOSTAGE pour la session", publipostagePJ(i))
If "" = Dir(PJ, vbNormal) Then GoTo quest
publipostagePJ(i) = PJ
Else: Exit For
End If
Next i
End If
MsgBox "Votre publipostage doit comporter le terme :" & vbCr & "PUBLIIDEM" & vbCr & "dans le sujet." & vbCr & "Celui-ci sera retiré lors de l'envoi"
End Sub