使用Excel VBA实现Outlook自动邮件发送的完整教程

使用Excel VBA实现Outlook自动邮件发送的完整教程

引用

CSDN

1.

https://blog.csdn.net/caixiaobaideye/article/details/140665718

本文将详细介绍如何使用Excel VBA实现Outlook自动邮件发送。通过创建一个支持宏的Excel文件，设置相关参数，并编写VBA代码，可以实现邮件的自动化发送。

1. 创建Excel文件

首先需要创建一个带有宏功能的Excel文件，文件后缀名为xlsm。这种文件格式支持宏的使用。

2. Excel操作

添加列

在Excel中添加以下列：

• 收件人：邮件接收者，多个收件人用分号（;）分隔
• 抄送人：抄送对象，多个抄送人用分号（;）分隔
• Outlook模板路径：保存的Outlook邮件模板路径，文件后缀为oft
• 替换内容：对模板中的内容进行替换，格式为：替换词1>替换内容1;替换词2>替换内容2
• 附件内容：添加附件的路径，多个附件用分号（;）分隔
• 插入图片：插入图片到指定位置，格式为：Image1>图片路径1;Image2>图片路径2
• 是否发送：设置邮件状态（1直接发送、0设置为草稿、2仅显示）

设置使用宏

要使用宏功能，需要在Excel中进行相应的设置：

进入Excel设置，勾选开发者窗口：

设置宏信任：

3. VBA代码编写

引用Outlook

发送代码

Sub SendEmail()
Dim smallMessenger As Outlook.Application
Set smallMessenger = New Outlook.Application
Dim newEmail As MailItem
Dim row, rows As Integer
Dim recipient As String
Dim ccRecipients As String
Dim subject As String
Dim outlookTemplatePath As String
Dim replacementContent As String
Dim attachmentContent As String
Dim insertImages As String
Dim sendDirectly As String
Dim strImageHTML As String
Dim i, j As Integer
Dim Before() As Variant
Dim Back() As Variant
Dim attachs() As String
rows = ActiveSheet.UsedRange.rows.Count
For i = 2 To rows
    recipient = Cells(i, "A")
    ccRecipients = Cells(i, "B")
    subject = Cells(i, "C")
    outlookTemplatePath = Cells(i, "D")
    replacementContent = Cells(i, "E")
    attachmentContent = Cells(i, "F")
    insertImages = Cells(i, "G")
    sendDirectly = Cells(i, "H")
    Set newEmail = smallMessenger.CreateItemFromTemplate(outlookTemplatePath)
    newEmail.To = recipient
    newEmail.CC = ccRecipients
    newEmail.subject = subject
    ' 鏇挎崲鍐呭
    If replacementContent = "" Then
        GoTo label1
    End If
    Before = getBefore(replacementContent)
    Back = getBack(replacementContent)
    For j = LBound(Before) To UBound(Before)
        newEmail.HTMLBody = Replace(newEmail.HTMLBody, Before(j), Back(j))
    Next
label1:
    ' 闄勪欢鍐呭
    If attachmentContent = "" Then
        GoTo label2
    End If
    attachs = Split(attachmentContent, ";")
    For j = LBound(attachs) To UBound(attachs)
        newEmail.Attachments.Add (attachs(j))
    Next
label2:
    '鎻掑叆鍥剧墖
    If insertImages = "" Then
        GoTo label3
    End If
    Before = getBefore(insertImages)
    Back = getBack(insertImages)
    For j = LBound(Before) To UBound(Before)
        strImageHTML = "<img src='" & Back(j) & "'>"
        newEmail.HTMLBody = Replace(newEmail.HTMLBody, Before(j), strImageHTML)
    Next
label3:
    If sendDirectly = 1 Then
        newEmail.Send
    ElseIf sendDirectly = 2 Then
        newEmail.Display
    ElseIf sendDirectly = 0 Then
        newEmail.Close olSave
    End If
Next
End Sub
Function getBefore(ByVal inputText As String) As Variant()
    Dim tokens() As String
    Dim result() As Variant
    Dim curtokens() As String
    
    Dim i As Integer
    tokens = Split(inputText, ";")
    ReDim result(0 To UBound(tokens))
    For i = LBound(tokens) To UBound(tokens)
        curtokens = Split(tokens(i), ">")
        result(i) = curtokens(0)
    Next
    getBefore = result
End Function
Function getBack(ByVal inputText As String) As Variant()
    Dim tokens() As String
    Dim result() As Variant
    Dim curtokens() As String
    
    Dim i As Integer
    tokens = Split(inputText, ";")
    ReDim result(0 To UBound(tokens))
    For i = LBound(tokens) To UBound(tokens)
        curtokens = Split(tokens(i), ">")
        result(i) = curtokens(1)
    Next
    getBack = result
End Function

创建按钮绑定宏

在Excel中创建一个按钮，并将其与编写的宏进行绑定，以便通过点击按钮来执行邮件发送操作。

一些问题

• Excel不保存宏：每次写完宏代码后，退出重新打开时不进行保存。解决办法是将Excel设置为英文形式。