excel - 带有 word 文档附件的 VBA 宏电子邮件

Question

我正在学习Excel VBA，我想将excel中的数据替换为word文档，并通过每行对应的电子邮件发送给员工。目前我已经发了电子邮件，但我不知道如何最好地附加word文档，我有数百名员工。谢谢你为我做的一切。

Sub sendMail()
 
 Dim OApp As Outlook.Application
 Set OApp = CreateObject("Outlook.Application")
 
 Dim mail_number As Integer
 mail_number = Excel.WorksheetFunction.CountA(ThisWorkbook.Sheets(1).Range("B:B"))

 Dim row As Integer
 For row = 2 To mail_number
    
    ' Open word document
    
    ' Replace data from excel and create word document temporary file
    
    Dim OMail As Outlook.MailItem
    Set OMail = OApp.CreateItem(OMailItem)
    OMail.To = ThisWorkbook.Sheets(1).Cells(row, 2)
    
    'OMail.Attachments.Add( ... word document temporary file
    
    OMail.Send
    
    ' Release memory
    
 Next
 
End Sub

标签： excelvba

Answer 1

如果我了解您的要求，以下代码可能会有所帮助。请注意，如果过程名称是 sendMail，您可能会遇到问题，因为 Excel 中已经存在该方法。对于此示例，我使用了名称 sendEmails。

Sub sendEmails()
On Error GoTo Error_Handler
    Dim OApp As Object
    Dim OMail As Object
    Dim WApp As Object
    Dim WDoc As Object
    Dim strTempFile As String
    Dim strWDocPath As String
    Dim row As Long
    Dim col As Long
    
    ' Replace FULL_PATH_NAME with the full name, including the path, of the Word document
    ' to use as a template, e.g. C:\Users\Sam\Documents\SalaryConfirmation.docx.
    ' The template can contain placeholders, e.g. <name>, which will be matched
    ' with the corresponding field names in the Excel worksheet.
    strWDocPath = "FULL_PATH_NAME"
    
    ' Check cell B1 = <mail>
    If [B1] <> "<mail>" Then
        MsgBox "Expected value ""<mail>"" in cell B1", vbCritical, "Failed"
        Exit Sub
    ' Check there is mail to send
    ElseIf Cells(Rows.Count, 2).End(xlUp).row = 1 Then
        MsgBox "No mail to send", vbInformation, "Exit"
        Exit Sub
    ' Check Word document path
    ElseIf strWDocPath = "" Or Dir(strWDocPath) = "" Then
        MsgBox "Word document not found: """ & strWDocPath & """", vbCritical, "Failed"
        Exit Sub
    End If

    Set OApp = CreateObject("Outlook.Application")
    Set WApp = CreateObject("Word.Application")
    
    For row = 2 To Cells(Rows.Count, 2).End(xlUp).row
        ' Create Word document from template
        Set WDoc = WApp.Documents.Add(strWDocPath)
        
        ' Replace field placeholders in Word document with values from respective fields in Excel
        For col = 3 To [A1].End(xlToRight).Column
            If Left(Cells(1, col), 1) = "<" And Right(Cells(1, col), 1) = ">" Then
                WDoc.Content.Find.Execute _
                    FindText:=Cells(1, col), ReplaceWith:=Cells(row, col), Replace:=2
            End If
        Next
        
        ' Save Word document in Temp folder
        strTempFile = Environ("Temp") & "\SalaryConfirmation.docx"
        WDoc.SaveAs2 strTempFile
        WDoc.Close 0
        
        ' Create email and attach Word document
        Set OMail = OApp.CreateItem(0)
        With OMail
            .To = Cells(row, 2)
            .Subject = "Salary confirmation"
            .Attachments.Add strTempFile
        End With
        
        ' Send email
        OMail.Send
    Next
    
    ' Clean up
    WApp.Quit 0
    ChDir Environ("Temp")
    Kill Dir(strTempFile)

Error_Exit:
    Exit Sub
Error_Handler:
    If Not OApp Is Nothing Then
        If Not OMail Is Nothing Then
            OMail.Close 1
        End If
    End If
    
    If Not WApp Is Nothing Then
        WApp.Quit 0
    End If
    
    MsgBox Err.Number & ": " & Err.Description, vbCritical, "Error"
    Resume Error_Exit
End Sub