群發帶附件的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