邮件合并到电子邮件与个性化附件和消息（图片和文本）

时间：2016-09-02 21:08:06

标签： vba ms-word outlook mailmerge

我正在尝试使个性化​​消息正常工作。在保留文本格式（粗体，斜体，......）的同时发送图片和文本很困难。

我在本网站上阅读了有关类似问题的相关主题（simulator）。它帮助我开始了。

我正在使用的代码：

Sub emailmergewithattachments_2()

Dim Source As Document, Maillist As Document, wdDoc As Document
Dim Datarange As Range
Dim wdRange As Range
Dim i As Long, j As Long
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim Insp As Outlook.Inspector
Dim MySubject As String, Message As String, Title As String

'The source document is Word document that contains the personnalised
'letters sent to the recipients
Set Source = ActiveDocument

' 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

'The Maillist is a 2 column table containing the email adress and the second column
'contains the path and the name of the file to be joined with the email
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 - 1

    Set oItem = oOutlookApp.CreateItem(olMailItem)
    With oItem
        .Subject = MySubject 'subject line

        'reading the first column of the maillist (the email)
        Set Datarange = Maillist.Tables(1).Cell(j, 1).Range
        Datarange.End = Datarange.End - 1
        .To = Datarange 'recipient's email

        'joining the personalised attachements to each recipient
        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

        'Obtain the Inspector for this Email
        Set Insp = oItem.GetInspector

        'Obtain the Word document for the Inspector
        Set wdDoc = Insp.WordEditor

        'Use the Range object to insert text
        Set wdRange = wdDoc.Range(0, wdDoc.Characters.Count)
        wdRange.InsertAfter ("Text inserted") 'for testing only (to check if it really working)

        'Word document containing the text and the images
        Windows("lettres.docx").Activate
        Selection.WholeStory

        '*******************************************************************************
        'Problematic part: trying to paste the selection into wdDoc while preserving the formatting
        'and the entire content of the document of the file "lettres.docx"

        '...missing code

        '********************************************************************************


        .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
End If

MsgBox Source.Sections.Count - 1 & " messages have been sent."

'Clean up
Set oOutlookApp = Nothing

End Sub

1 个答案:

答案 0 :(得分：0)

我采取了不同的方法。我在MS Word中进行了常规邮件合并，并以HTML格式发送邮件，该格式保留了所有格式和图形。然后在Outlook中，我创建了一个宏，在发送每封电子邮件时添加附件。 Excel工作表包含每个电子邮件要加入的文件的路径。

<强> ==＆GT;重要提示：在将数据从Word发送到Outlook 之前必须打开Outlook（应用程序已加载），否则电子邮件可能会卡在发件箱中，因此宏将无法正常工作（电子邮件将被发送但没有附件）

ThisOutlookSession中的代码： 

 Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

If Item.Class = olMail Then
    Dim objCurrentMessage As MailItem
    Set objCurrentMessage = Item
    If UCase(objCurrentMessage.Subject) Like "PUBLIIDEM*" Then
        On Error Resume Next
        'Pour ajouter la même PJ à tous
        Dim i As Long
        i = 0
        If publipostagePJ <> "" Then
            While publipostagePJ(i) <> "fin"
                objCurrentMessage.Attachments.Add Source:=publipostagePJ(i)
                i = i + 1
            Wend
        End If

        'On supprime le terme PUBLIIDEM du sujet
        objCurrentMessage.Subject = Replace(objCurrentMessage.Subject, "PUBLIIDEM ", "")

    ElseIf UCase(objCurrentMessage.Subject) Like "PUBLIPERSO*" Then

        If Chemin = "" Then
            Chemin = InputBox("Entrez le chemin d'accès et le nom du fichier:", "Envoies personnalisés")

            On Error Resume Next
            Set oExcelApp = GetObject(, "Excel.Application")

            If Err <> 0 Then
                Set oExcelApp = CreateObject("Excel.Application")
                bStarted = True
            End If

            Workbooks.Open Chemin
            Set oWB = Excel.ActiveWorkbook
            oWB.Sheets("fichiers").Select
            DerniereLigne = Cells(Rows.Count, 1).End(xlUp).Row
            'DerniereColonne = Cells(1, Columns.Count).End(xlToLeft).Column
        End If

         For i = 1 To DerniereLigne
            If Cells(i, 1) = objCurrentMessage.To Then
                For j = 2 To 5
                    FichierJoin = Cells(i, j)
                    If Len(FichierJoin) > 0 Then objCurrentMessage.Attachments.Add Source:=FichierJoin
                Next j
            End If
        Next i

        'On supprime le terme PUBLIPERSO du sujet
        objCurrentMessage.Subject = Replace(UCase(objCurrentMessage.Subject), "PUBLIPERSO ", "")

    End If

    Set objCurrentMessage = Nothing

End If
End Sub

Private Sub Application_Quit()
    If bStarted Then
       oExcelApp.Quit
    End If
    Set oExcelApp = Nothing
    Set oWB = Nothing
End Sub

模块中的代码 

Public publipostagePJ As Variant
Public oExcelApp As Excel.Application
Public oWB As Excel.Workbook
Public DerniereLigne As Long
Public DerniereColonne As Long
Public bStarted As Boolean
Public FichierJoin, Chemin As String

Sub setPublipostage()
    On Error Resume Next
    If publipostagePJ(0) = "" Then publipostagePJ = Array("fin", "fin", "fin", "fin", "fin", "fin", "fin", "fin", "fin", "fin")

    While publipostagePJ(i) <> "fin"
        contenu = contenu & vbCr & publipostagePJ(i)
        i = i + 1
    Wend

    If contenu = "" Then contenu = "vide"

    modifier = MsgBox(contenu & vbCr & "Voulez vous modifier les fichiers ?", vbYesNo, "Fichiers paramétrés")
    If modifier = vbYes Then
    For i = 0 To 9
        If i > 0 Then encore = MsgBox("un autre ?", vbYesNo)
quest:
            If encore <> vbNo Then
                PJ = InputBox("Emplacement du fichier joint au PUBLIPOSTAGE?", _
                "Paramétrage du PUBLIPOSTAGE pour la session", publipostagePJ(i))

            If "" = Dir(PJ, vbNormal) Then GoTo quest
            publipostagePJ(i) = PJ

    Else: Exit For

    End If

    Next i

    End If

    MsgBox "Votre publipostage doit comporter le terme :" & vbCr & "PUBLIIDEM" & vbCr & "dans le sujet." & vbCr & "Celui-ci sera retiré lors de l'envoi"

End Sub
相关问题
最新问题