Question

我想从Excel中通过MS Outlook发送自动邮件。

问题是写邮件的正文。我在Excel单元格中为每个员工提供了一个单独的Word文件，并带有指向它的超链接。我想打开Word文件并使用相同的格式复制Word文档中的所有内容然后粘贴到邮件正文中。

在我的Excel工作簿中，A到E列如下所示。

A栏：员工姓名
B栏：邮件ID
C栏：CC邮件ID
D栏：主题
E栏：超链接到Word文件（需要打开文件复制并粘贴在邮件正文中）
F列到Z列：附件（任何类型的附件）

Sub Send_Files()

'Make a list in Sheets("Sheet1") with :

'In column A : Names of the people
'In column B : E-mail addresses
'In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)

'The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
'and file name(s) in column C:Z it will create a mail with this information and send it.

'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set sh = Sheets("Sheet1")

Set OutApp = CreateObject("Outlook.Application")

For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

    'Enter the path/file names in the C:Z column in each row
    Set rng = sh.Cells(cell.Row, 1).Range("F1:Z1")

    If cell.Value Like "?*@?*.?*" And _
        Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)

        With OutMail
            .to = cell.Value
            .cc = cell.Offset(0, 1).Value
            .Subject = cell.Offset(0, 2).Value
            .Body = "Hi" & cell.Offset(0, -1).Value
            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell

            .Send  'Or use .Display
        End With
        Set OutMail = Nothing
    End If[enter link description here][1]
Next cell
Set OutApp = Nothing
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

拍摄邮件内容的正文。

Answer 1

技巧是获取粘贴格式的Word文档内容。为此，您需要附加MS Word是Outlook邮件项目的编辑器。

此外，从您上面的示例Word文档中，您希望为用户个性化电子邮件。因此，将Word文档修改为“亲爱的XXXNAMEXXX”，然后执行查找/替换（如代码所示）。

Option Explicit

Sub Send_Files()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim OutMailEditor As Object
    Dim WordApp As Object
    Dim WordDoc As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")
    Set OutApp = CreateObject("Outlook.Application")
    Set WordApp = CreateObject("Word.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("F1:Z1")

        If cell.Value Like "?*@?*.?*" And _
            Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
            'copy/paste the body of the email and change the name
            Set OutMailEditor = OutMail.GetInspector.WordEditor
            Set WordDoc = WordApp.documents.Open(Filename:=cell.Offset(0, 3).Value, ReadOnly:=True)
            WordDoc.Content.Copy
            OutMailEditor.Range.Paste
            With OutMailEditor.Range.Find
                .Text = "XXXNAMEXXX"
                .Replacement.Text = cell.Offset(0, -1).Value
                .Wrap = 1
                .Forward = True
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2
            End With

            With OutMail
                .to = cell.Value
                .cc = cell.Offset(0, 1).Value
                .Subject = cell.Offset(0, 2).Value
                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With
            Set OutMail = Nothing
            Set WordDoc = Nothing
        End If
    Next cell
    Set OutApp = Nothing
    Set WordApp = Nothing

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

从Excel打开Word文档并将内容粘贴到Outlook邮件的正文

1 个答案: