利用word邮件合并功能群发带附件的邮件的VBA代码问题

韵鑫音响

各位，我是利用word邮件合并功能群发带附件的邮件的，但是我使用如下宏代码之后，的确发送成功了。邮件字体和排版很难看，我编辑的是英文times new roman，结果发出去邮件全部是默认宋体，也没有段落，好像这个宏代码没有包含字体等格式的，只是将字符发送出去。各位，看看能如何修改呢？ 代码里这句貌似说的是字体格式等：   .Body = docSource.Sections(j).Range.Text

发送邮件的宏代码如下：

Sub eMailMergeWithAttachments()

    Dim docSource As Document, docMaillist As Document, docTempDoc As Document

    Dim rngDatarange As Range

    Dim i As Long, j As Long

    Dim lSectionsCount As Long

    Dim bStarted As Boolean

    Dim oOutlookApp As Outlook.Application

    Dim oItem As Outlook.MailItem

    Dim oAccount As Outlook.Account

    Dim sMySubject As String, sMessage As String, sTitle As String

    '将当前文档设置为源文档（主文档）

    Set docSource = ActiveDocument

    '检查Outlook是不是打开了。如果未打开的话，就打开新的Outlook

    On Error Resume Next

    Set oOutlookApp = GetObject(, "Outlook.Application")

    If Err <> 0 Then

        Set oOutlookApp = CreateObject("Outlook.Application")

        bStarted = True

    End If

    '打开保存有客人的邮件地址和需要发送的附件的路径的word文档。

    With Dialogs(wdDialogFileOpen)

        .Show

    End With

    '将该文档设置为客户邮件（附件）列表文档

    Set docMaillist = ActiveDocument

    '设置发送邮件的账户（账户必须已经在Outlook中设置好了）

    '注意：如果你的Outlook版本低于2007，使用设置发送邮件的账户可能会导致错误，

    '建议将下面的Set oAccount = oOutlookApp.Session.Accounts.Item("someone@examplemail.com")语句删除

    Set oAccount = oOutlookApp.Session.Accounts.Item("someone@examplemail.com")

    '显示一个输入框，询问并让用户输入邮件主题

    sMessage = "请为要发送的邮件输入邮件主题。"

    sTitle = "输入邮件主题"

    sMySubject = InputBox(sMessage, sTitle)

    '循环查找源文档中所有的节（每一节为一封邮件内容），以及循环查找邮件列表文档中所有的客户信息，

    '以便用于插入到生成的邮件中

    lSectionsCount = docSource.Sections.Count - 1

    '当源文档中的节数仅有1时，lSectionsCount=0，将导致程序无法正常运行。

    '为了保证当源文档只有1节时程序能正常运行，必须使lSectionsCount至少等于1

    If lSectionsCount = 0 Then lSectionsCount = 1

    For j = 1 To lSectionsCount

        Set oItem = oOutlookApp.CreateItem(olMailItem)

        With oItem

            '注意：如果你的Outlook版本低于2007，使用设置发送邮件的账户可能会导致错误，

            '建议将下面的.SendUsingAccount = oAccount语句删除

            .SendUsingAccount = oAccount

            .Subject = sMySubject

            .Body = docSource.Sections(j).Range.Text

            Set rngDatarange = docMaillist.Tables(1).Cell(j, 1).Range

            rngDatarange.End = rngDatarange.End - 1

            .To = rngDatarange

            For i = 2 To docMaillist.Tables(1).Columns.Count

                Set rngDatarange = docMaillist.Tables(1).Cell(j, i).Range

                rngDatarange.End = rngDatarange.End - 1

                .Attachments.Add Trim(rngDatarange.Text), olByValue, 1

            Next i

            .Send

        End With

        Set oItem = Nothing

    Next j

    docMaillist.Close wdDoNotSaveChanges

    '如果Outlook是由该宏打开的，则关闭Outlook

    If bStarted Then

        oOutlookApp.Quit

    End If

    MsgBox "共发送了 " & lSectionsCount & " 封邮件。"

    '清空Outlook实例

    Set oOutlookApp = Nothing

End Sub

请高手帮帮忙看看。对了，我是用outlook与word结合发邮件的。先谢谢啦！

wudixin96

WORD邮件合并群发还需要用到VBA？？？

韵鑫音响

wudixin96 发表于 2012-8-31 17:50
WORD邮件合并群发还需要用到VBA？？？

带附件的邮件！！！！

用word邮件合并群发带附件的邮件，所以用到宏啊。如果只是文档，邮件合并确实就能解决了。

小飞侠iv

还是看不懂，这些语句copy进去没法实现呀。有没有高手指教下。急用！！！！！！！

huguifang

邮件合并发附件，我用老外的mail merge toolkit，傻瓜化操作，可惜收费，但可以用1月。

emily901

邮件合并可以选择带附件或者直接文本的

全心全意

我也是WORD合并邮件前字体是Verdana，合并后邮件字体却变成了宋体，还没有办法解决吗？

dianadeng

同问这种方式发邮件造成的格式问题有解决方法吗？

相见是缘8

dianadeng 发表于 2019-2-14 08:06
同问这种方式发邮件造成的格式问题有解决方法吗？

以前在网上看到的，不知有用否？？？

Sub eMailMergeWithAttachments()

    Dim docSource As Document, docMaillist As Document,docTempDoc As Document

    Dim rngDatarange As Range

    Dim i As Long, j As Long

    Dim lSectionsCount As Long

    Dim bStarted As Boolean

    Dim oOutlookApp As Outlook.Application

    Dim oItem As Outlook.MailItem

    Dim oAccount As Outlook.Account

    Dim sMySubject As String, sMessage As String,sTitle As String

    '将当前文档设置为源文档（主文档）

    Set docSource = ActiveDocument

    '检查Outlook是不是打开了。如果未打开的话，就打开新的Outlook

    On Error Resume Next

    Set oOutlookApp = GetObject(,"Outlook.Application")

    If Err <> 0 Then

        Set oOutlookApp =CreateObject("Outlook.Application")

        bStarted = True

    End If

    '打开保存有客人的邮件地址和需要发送的附件的路径的word文档。

    With Dialogs(wdDialogFileOpen)

        .Show

    End With

    '将该文档设置为客户邮件（附件）列表文档

    Set docMaillist = ActiveDocument

    '设置发送邮件的账户（账户必须已经在Outlook中设置好了）

    '注意：如果你的Outlook版本低于2007，使用设置发送邮件的账户可能会导致错误，

    '建议将下面的Set oAccount =oOutlookApp.Session.Accounts.Item("someone@examplemail.com")语句删除

    Set oAccount =oOutlookApp.Session.Accounts.Item("someone@examplemail.com")

    '显示一个输入框，询问并让用户输入邮件主题

    sMessage = "请为要发送的邮件输入邮件主题。"

    sTitle = "输入邮件主题"

    sMySubject = InputBox(sMessage, sTitle)

    '循环查找源文档中所有的节（每一节为一封邮件内容），以及循环查找邮件列表文档中所有的客户信息，

    '以便用于插入到生成的邮件中

    lSectionsCount = docSource.Sections.Count - 1

    '当源文档中的节数仅有1时，lSectionsCount=0，将导致程序无法正常运行。

    '为了保证当源文档只有1节时程序能正常运行，必须使lSectionsCount至少等于1

    If lSectionsCount = 0 Then lSectionsCount = 1

    For j = 1 To lSectionsCount

        Set oItem =oOutlookApp.CreateItem(olMailItem)

        With oItem

            '注意：如果你的Outlook版本低于2007，使用设置发送邮件的账户可能会导致错误，

            '建议将下面的.SendUsingAccount = oAccount语句删除

            .SendUsingAccount= oAccount

            .Subject= sMySubject

            '把邮件正文复制到剪贴板

            docSource.Sections(j).Range.Copy

            '显示邮件

            .Display

            '注意：使用以下方法，必须保证outlook正在使用的是Word编辑器

            SetdocTempDoc = oOutlookApp.ActiveInspector.WordEditor

            '粘贴邮件正文到outlook

            docTempDoc.Range.Paste

            SetrngDatarange = docMaillist.Tables(1).Cell(j, 1).Range

            rngDatarange.End= rngDatarange.End - 1

            .To= rngDatarange

            Fori = 2 To docMaillist.Tables(1).Columns.Count

                SetrngDatarange = docMaillist.Tables(1).Cell(j, i).Range

                rngDatarange.End= rngDatarange.End - 1

                .Attachments.AddTrim(rngDatarange.Text), olByValue, 1

            Nexti

            '如果需要立即发送邮件，请把下面一行的注释去掉

            '.Send

        End With

        Set oItem = Nothing

    Next j

    docMaillist.Close wdDoNotSaveChanges

    '如果Outlook是由该宏打开的，则关闭Outlook

    If bStarted Then

        oOutlookApp.Quit

    End If

    MsgBox "共发送了 " & lSectionsCount & " 封邮件。"

    '清空Outlook实例

    Set oOutlookApp = Nothing

End Sub

另外一个方法是把word的正文保存为htm格式，然后通过FileSystemObject读取该文件内容。坏处是，所有邮件的正文的内容都是一样的。这里也把代码说一下。

Function GetBoiler(ByVal sFile As String) As String

    Dim fso As Object

    Dim ts As Object

    Set fso =CreateObject("Scripting.FileSystemObject")

    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)

    GetBoiler = ts.Readall

    ts.Close

End Function

记得要把eMailMergeWithAttachments过程中的

.Body = docSource.Sections(j).Range.Text

改成

.HtmlBody = GetBoiler("D:\myattachment.pdf")