Microsoft Office Forums - View Single Post

macropod · 12-03-2011, 02:47 PM

Hi wowow,

First off, you need to set a refernce to Outlook in the vbe. To do this, open the vbe and go to Tools|References, scroll down till you find the Microsoft Outlook # Object Library and check it.

Then, there are some errors in the code, mainly in the form of wrapped comment lines that either shouldn't be or should begin with a tick mark. Finally, your .CC line is wrong - you've omitted the expressions you had before. I've fixed these issues in the following code:

Code:

Sub EmailMergeWithAttachments()
'To create the email messages in HTML format
Dim source As Document, Maillist As Document, TempDoc As Document
Dim datarange As Range, i As Long, j As Long, bStarted As Boolean
Dim oOutlookApp As Outlook.Application, oItem As Outlook.MailItem
Dim mysubject As String, message As String, Title As String
Dim objDoc, objSel

Set source = ActiveDocument
' Check if Outlook is running. If it is not, start Outlook
On Error Resume Next
Set oOutlookApp = GetObject(, "Outlook.Application")
If Error = 0 Then
  Set oOutlookApp = CreateObject("Outlook.Application")
  bStarted = True
End If

' Open the catalog mailmerge document
Dialogs(wdDialogFileOpen).Show

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
  source.Sections(j).Range.Copy
  Set oItem = oOutlookApp.CreateItem(olMailItem)
  With oItem
    .Subject = mysubject
    .BodyFormat = olFormatHTML
    .Display
    Set objDoc = .GetInspector.WordEditor
    Set objSel = objDoc.Windows(1).Selection
    objSel.Paste
    Set datarange = Maillist.Tables(1).Cell(j, 1).Range
    datarange.End = datarange.End - 1
    .To = datarange
    .cc = "Firstemailaddress; secondemailaddress"
    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
    .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

MsgBox source.Sections.Count & " messages have been sent."
'Clean up
Set oOutlookApp = Nothing
End Sub

Note: You should alsways use 'Option Explicit' in a code module, so that any undeclared and/or mis-named variables etc will the captured before they cause problems.