VBA Mail Merge incl attachment using Word Editor plus distrubotion list - 1st email no body

[francoisblake]

Good day all from a sunny South Africa

I have a VBA code that work fine 99%
It creates an email
Add an attachment
Personalise the email
Have a distribution list
Use a default body created in advance
Can set a time delay between emails etc.

The only problem
The first email adds the attachment, sends it to the correct email address but does not include the body
All the emails after that includes the body

It is a minor bug it would be great to sort it out
Please advise where I made a fault
I have only been using VBA for the last month or so, please correct me where I am wrong

Thank you
Francois

Herewith the code

Sub SendDocumentInMail()

Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim mysubject As String, message As String, title As String
Dim j As Integer, x As Integer
Dim emailRng As Range
Dim wordapp As Word.Application
Dim wordText As Object
Dim exelText As String
Dim fileName As String
Dim copyWord As Object
Dim OutInsp As Outlook.Inspector
Dim WdApp As Word.Application
Dim OutDoc As Word.Document
Dim WdSel As Word.Selection
Dim timeRng As Range


Set emailRng = ThisWorkbook.Sheets("Sheet2").Columns(1)
x = WorksheetFunction.CountIf(emailRng, "*?")
fileName = ThisWorkbook.Sheets("Sheet2").Cells(2, 6).Value

On Error Resume Next
'Get Outlook if it's running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn't running, start it from code
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If

' 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)

For j = 1 To x

'Create a new mailitem
Set oItem = oOutlookApp.CreateItem(olMailItem)


With oItem

'delay sending
Set timeRng = ThisWorkbook.Sheets("Sheet2").Range("F3:F5")
If WorksheetFunction.Sum(timeRng) > 0 Then
Application.Wait Time + TimeSerial(ThisWorkbook.Sheets("Sheet2").Range("F3"), _
ThisWorkbook.Sheets("Sheet2").Range("F4"), _
ThisWorkbook.Sheets("Sheet2").Range("F5"))
End If

'Set email body as HTML
.BodyFormat = olFormatHTML

'Set the recipient for the new email
.To = ThisWorkbook.Sheets("Sheet2").Cells(j, 1)

'Set the recipient for a copy
If Not IsEmpty(ThisWorkbook.Sheets("Sheet2").Cells(j, 2)) Then
.CC = ThisWorkbook.Sheets("Sheet2").Cells(j, 2)
End If

'Get the subject
.Subject = mysubject

Set ThisWorkbook.Sheets("sheet2") = ActiveDocument

'The content of the document is used as the body for the email plus personlise
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open fileName
wordapp.Visible = True

ThisWorkbook.Sheets("Sheet2").Range("D2").clearcontent

'Greating and salutation from Sheet2
excelText = ThisWorkbook.Sheets("Sheet2").Range("D1") & " " _
& ThisWorkbook.Sheets("Sheet2").Cells(j, 3)
ThisWorkbook.Sheets("Sheet2").Range("D2") = excelText
ThisWorkbook.Sheets("Sheet2").Range("D2").Copy


'Paste Greeting and Salutation
Set wordText = wordapp.ActiveDocument
wordapp.Selection.PasteSpecial DataType:=wdPasteText

wordapp.Selection.WholeStory
wordapp.Selection.Copy

'Create and paste in Word Editor
Set OutInsp = oItem.GetInspector
Set OutDoc = OutInsp.WordEditor
Set WdApp = OutDoc.Application
Set WdSel = WdApp.Selection

WdSel.PasteAndFormat Type:=wdFormatOriginalFormatting

'close Word Document
wordapp.Quit False

'Add attachment
.Attachments.Add source:=ThisWorkbook.Sheets("Sheet2").Cells(1, 6).Value

'Display email
.Display

'Wait 1 second to ensure pasting
Application.Wait (Now + TimeValue("00:00:01"))

'Send email
.Send

End With

'Clean up Word Editor
Set WdSel = Nothing
Set OutInsp = Nothing
Set OutMail = Nothing
Set OutDoc = Nothing
Set WdApp = Nothing
Set OutApp = Nothing

Next j


If bStarted Then
'If we started Outlook from code, then close it
oOutlookApp.Quit
End If

'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set wordapp = Nothing
Set copyWord = Nothing
Set wordText = Nothing


End Sub

 

[francoisblake]

Hi All

I changed the following

For j = 1 To x 'before

For j = 2 To x

Now it works 100%

For fun I also added a msgbox at the end that counts the amount of emails sent and informs you

 

[francoisblake]

Hi All

It did the same again
So I have added an if

Here is the updated code

Sub SendDocumentInMail()

Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim mysubject As String, message As String, title As String
Dim j As Integer, x As Integer
Dim emailRng As Range
Dim wordapp As Word.Application
Dim wordText As Object
Dim exelText As String
Dim fileName As String
Dim copyWord As Object
Dim OutInsp As Outlook.Inspector
Dim WdApp As Word.Application
Dim OutDoc As Word.Document
Dim WdSel As Word.Selection
Dim timeRng As Range
Dim boxCount As Integer 'amount of emails sent


Set emailRng = ThisWorkbook.Sheets("Sheet2").Columns(1)
x = WorksheetFunction.CountIf(emailRng, "*?")
fileName = ThisWorkbook.Sheets("Sheet2").Cells(2, 6).Value

On Error Resume Next
'Get Outlook if it's running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn't running, start it from code
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If

' 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)

Set wordapp = CreateObject("word.Application")
wordapp.documents.Open fileName
wordapp.Visible = True

wordapp.Quit False

For j = 2 To x

'Create a new mailitem
Set oItem = oOutlookApp.CreateItem(olMailItem)


With oItem

'delay sending
Set timeRng = ThisWorkbook.Sheets("Sheet2").Range("F3:F5")
If WorksheetFunction.Sum(timeRng) > 0 Then
Application.Wait Time + TimeSerial(ThisWorkbook.Sheets("Sheet2").Range("F3"), _
ThisWorkbook.Sheets("Sheet2").Range("F4"), _
ThisWorkbook.Sheets("Sheet2").Range("F5"))
End If

'Set email body as HTML
.BodyFormat = olFormatHTML

'Set the recipient for the new email
.To = ThisWorkbook.Sheets("Sheet2").Cells(j, 1)

'Set the recipient for a copy
If Not IsEmpty(ThisWorkbook.Sheets("Sheet2").Cells(j, 2)) Then
.CC = ThisWorkbook.Sheets("Sheet2").Cells(j, 2)
End If

'Get the subject
.Subject = mysubject


'The content of the document is used as the body for the email plus personlise
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open fileName
wordapp.Visible = True

Set ThisWorkbook.Sheets("sheet2") = ActiveDocument

ThisWorkbook.Sheets("Sheet2").Range("D2").clearcontent

'Greating and salutation from Sheet2
excelText = ThisWorkbook.Sheets("Sheet2").Range("D1") & " " _
& ThisWorkbook.Sheets("Sheet2").Cells(j, 3)
ThisWorkbook.Sheets("Sheet2").Range("D2") = excelText
ThisWorkbook.Sheets("Sheet2").Range("D2").Copy

'Paste Greeting and Salutation
Set wordText = wordapp.ActiveDocument
wordapp.Selection.PasteSpecial DataType:=wdPasteText

wordapp.Selection.WholeStory
wordapp.Selection.Copy

'Create and paste in Word Editor
Set OutInsp = oItem.GetInspector
Set OutDoc = OutInsp.WordEditor
Set WdApp = OutDoc.Application
Set WdSel = WdApp.Selection

'Wait 1 second to ensure pasting
Application.Wait (Now + TimeValue("00:00:01"))

WdSel.PasteAndFormat Type:=wdFormatOriginalFormatting

'close Word Document
wordapp.Quit False

If j = 2 Then
WdSel.PasteAndFormat Type:=wdFormatOriginalFormatting
End If

'Add attachment
.Attachments.Add source:=ThisWorkbook.Sheets("Sheet2").Cells(1, 6).Value

'Display email
.Display

'Wait 1 second to ensure pasting
Application.Wait (Now + TimeValue("00:00:01"))

'Send email
.Send

boxCount = boxCount + 1

End With

'Clean up Word Editor
Set WdSel = Nothing
Set OutInsp = Nothing
Set OutMail = Nothing
Set OutDoc = Nothing
Set WdApp = Nothing
Set OutApp = Nothing

Next j


If bStarted Then
'If we started Outlook from code, then close it
oOutlookApp.Quit
End If

'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set wordapp = Nothing
Set copyWord = Nothing
Set wordText = Nothing

MsgBox boxCount & " email(s) have been sent"


End Sub