Recently there was a thread where a member asked for a solution to send several emails with a text from one Word-document and where the recipient-groups are in a worksheet.
Below You find a fully workable example-procedure based on the following:
- A bookmark is used for the textrange in the Word-document.
- The groups of recipients are in columns, i e one group per column.
In the example early binding is used and therefore it require that we set references to the following libraries:
* Microsoft Word x.x Library
* Microsoft Outlook x.x Library
* MIcrosoft Forms x.x Library
The example has been developed with the following softwares:
* MS Excel 2000 SP-3
* MS Word 2003 SP-1
* MS Outlook 2003 SP-1
* MS Windows 2000 SP-4
Code
Option Explicit
Sub Send_Email_Groups()
'Variables for MS Excel.
Dim wbBook As Excel.Workbook
Dim wsSheet As Excel.Worksheet
Dim doText As DataObject
Dim vaGroup As Variant
Dim i As Long, j As Long
On Error GoTo Error_Handling
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Blad1")
'Variables for MS Word.
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim bmRange As Word.Range
Dim stFile As String
'Full path and name for the Word-file.
stFile = ThisWorkbook.Path & "\BodyMsg.doc"
'Instantiate and open MS Word COM's objects.
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open(stFile)
'We use here a bookmark for the text.
Set bmRange = wdDoc.Bookmarks("Body").Range
'Copy the text to the clipboard.
bmRange.Copy
'Instantiate the Form COM object.
Set doText = New DataObject
'Retrieve the text from the clipboard.
doText.GetFromClipboard
'Variables for MS Outlook.
Dim olApp As Outlook.Application
Dim olNewMail As Outlook.MailItem
'Instantiate Outlook COM's objects and create new mailitems.
Set olApp = New Outlook.Application
Const stMsg As String = "As per agreement."
'Retrieve the first group of recipients.
With wsSheet
vaGroup = .Range(.Cells(2, 1), .Cells(65536, 1).End(xlUp)).Value
End With
'Create a new mail, add data to its properties and send it as long
'as there exist recipient-groups.
Do While UBound(vaGroup) > 2
i = i + 1
Set olNewMail = olApp.CreateItem(olMailItem)
With olNewMail
'Works with Outlook 2003.
For j = 1 To UBound(vaGroup)
.Recipients.Add vaGroup(j, 1)
Next
.Subject = stMsg
.Body = doText.GetText
.Save
.Send
End With
'Populate the variant-array with new data.
With wsSheet
vaGroup = .Range(.Cells(2, i + 1), .Cells(65536, i + 1).End(xlUp)).Value
End With
Set olNewMail = Nothing
Loop
wdDoc.Close
wdApp.Quit
olApp.Quit
ExitHere:
Application.CutCopyMode = False
'Release objects from memory.
Set bmRange = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
Set olNewMail = Nothing
Set olApp = Nothing
Exit Sub
Error_Handling:
MsgBox "Err: " & Err.Description & vbCrLf & _
"Number: " & Err.Number
Resume ExitHere
End Sub
Display More
Let´s face it once for all - Automation rocks