群发带附件的VBA程序

Sub emailmergewithattachments()
'
' emailmergewithattachments Macro
' 宏在 2007-9-28 由 longmb 创建
'
Dim Source As Document, Maillist As Document
Dim Datarange As Range
Dim Counter As Integer, i As Integer
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim mysubject As String, message As String, title As String
 
Set Source = ActiveDocument
Set Text = Source.Content

'Selection.WholeStory
 '   Selection.Copy

 
' 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
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 = "sub" 'InputBox(message, title)

 
' Iterate through the rows of the catalog mailmerge document, extracting the information
' to be included in each email.
Counter = 1
rowNum = Maillist.Tables(1).Rows.Count
While Counter <= rowNum
  
    Dim temDocument As Document
    Set temDocument = Documents.Add
   
   
    Maillist.Tables(1).Cell(Counter, 2).Range.Copy
    Selection.Paste
   
    Source.Sections.First.Range.Copy
    'Source.Activate
    'Source.Sections.First.Range.WholeStory
    'Selection.Copy
   
    'temDocument.Activate
    Selection.PasteAndFormat (wdPasteDefault)
   
   
    'Selection.Paste
    'Selection.MoveStart
   
    Set oItem = oOutlookApp.CreateItem(olMailItem)
    With oItem
        .Subject = mysubject
       
       
        .Body = ActiveDocument.Content
       
        Set Address = Maillist.Tables(1).Cell(Counter, 1).Range
        Address.End = addressDatarange.End - 1
        .To = Address
       
        Set emailName = Maillist.Tables(1).Cell(Counter, 2).Range
      
        '.Body = emailName
        'Selection.PasteAndFormat (wdPasteDefault)
       
       
   
       
        attachmentNum = Maillist.Tables(1).Columns.Count
        For i = 3 To attachmentNum
            Set Datarange = Maillist.Tables(1).Cell(Counter, i).Range
            Datarange.End = Datarange.End - 1
            .Attachments.Add Trim(Datarange.Text), olByValue, 1
        Next i
        .Send
    End With
    Set oItem = Nothing
    temDocument.Close wdDoNotSaveChanges
    Counter = Counter + 1
Wend
 
'  Close Outlook if it was started by this macro.
If bStarted Then
    oOutlookApp.Quit
End If
 
'Clean up
Set oOutlookApp = Nothing
'Source.Close wdDoNotSaveChanges
Maillist.Close wdDoNotSaveChanges

End Sub