Excel 利用VBA 发邮件

利用Excel的Outlook Application发送邮件

From为当前登录用户

Sub Sendmail()
   Application.ScreenUpdating = False
   On Error Resume Next
   Dim Temp As Object
   Dim Newmail As Object
   Dim strBody As String
   Dim email As Excel.Application, emailBook As Excel.Workbook
   Set email = CreateObject("excel.application")
   'Set emailBook = email.Workbooks.Open("D:xxx.xlsx")
   Set Temp = CreateObject("outlook.application")
   Set Newmail = Temp.CreateItem(0)
   strBody = Replace(Worksheets("Sheet1").Range("E2").Value, "{Name}", Worksheets("Sheet1").Range("A2").Value)
   With Newmail
       'With emailBook
           .To = Worksheets("Sheet1").Range("C2").Value
           .CC = Worksheets("Sheet1").Range("D2").Value
           .Subject = Worksheets("Sheet1").Range("B2").Value
           .Body = strBody
           '.Attachments.Add ("D:xxx.docx")
           .Send
       'End With
   End With
   Set Temp = Nothing
   Set Newmail = Nothing
   Application.ScreenUpdating = True

　　emailBook.Close SaveChanges:=False

　　email.Quit

End Sub

邮件的Excel模板为：

也可以写成循环，遍历行发送邮件。

Set rngRows = emailBook.Worksheets("Sheet1").Range("A2:F10")
rowNumber = 1
For Each myRow In rngRows.Rows
    temp2 = myRow.Cells(rowNumber, 1).Value
    If temp2 <> "" Then
      With Newmail
        .To = myRow.Cells(rowNumber, 3).Value
        .CC = myRow.Cells(rowNumber, 6).Value
        .Subject = myRow.Cells(rowNumber, 4).Value
        .Body = strBody1
        .Attachments.Add ("xxxx")
        .Attachments.Add ("xxxx")
        .Send
    End With
  　Set temp = Nothing
    Set Newmail = Nothing
  End If
Next