VBA自动发送邮件+内容+附件

2019独角兽企业重金招聘Python工程师标准>>>

网上看到的一个例子，需要将以下表格根据内容将近7天的数据自动发送给不同的客户。

原始数据如下：

需要将生的最近n天明细表格如下

大概思路如下：获取邮箱->处理数据->生成EXCEL->生成Email

在实际处理中，比较困难的Email在内容中添加数据时，不能直接复制表格。一定要将数据转换成htm才能添加。

具体代码如下：

Const d_Span = 7

Sub AutoEmail_Html()
'---------------Define Workbook------------------------------
Dim Dic As Object, Pin$, key, k
Dim c_Date As Date, b_Date As Date
Dim arr, brr
Dim wb As Workbook
'---------------Define Outlook-------------------------------
Dim wbStr As String, nlist As String
Dim OutlookApp As Outlook.Application
Dim OutlookItem As Outlook.MailItem
Dim newMail
Dim strAdr$
'=============================================================
Application.ScreenUpdating = False
arr = Sheet1.UsedRange        '原始数据
'日期区间
c_Date = Date: b_Date = c_Date - d_Span
Set Dic = CreateObject("Scripting.Dictionary")
'获取名字+Email,用以文件循环
For i = 2 To UBound(arr)
    Pin = arr(i, 2)
    If Not Dic.Exists(Pin) And Pin <> "" Then Dic(Pin) = arr(i, 22)
Next i
key = Dic.keys
'----------------Process Data----------------------------------
For k = 0 To UBound(key)
    Pin = key(k)    'PIN
    brr = Get_Data_From_Array(arr, Pin, c_Date, b_Date)
    If Not IsArray(brr) Then Exit Sub
    '新建工作表，用以Email附件
    Set wb = Workbooks.Add
    wb.Sheets(1).[A1].Resize(UBound(brr), UBound(brr, 2)) = brr
    wb.SaveAs ThisWorkbook.Path & "\" & Pin & ".xlsx"
    wbStr = wb.FullName
    wb.Close
    strAdr = ThisWorkbook.Path & "\" & Pin
    '---------------run OUTLOOK EMAIL------------------------------
    Set OutlookApp = New Outlook.Application
    Set OutlookItem = OutlookApp.CreateItem(olMailItem)
        With OutlookItem
            .Subject = "提醒您撞线啦！"
            .BodyFormat = Outlook.OlBodyFormat.olFormatHTML    '添加表格内容须设为HTML格式
            .HTMLBody = RangeToHTML(brr, strAdr)     'Array转为HTML的内容
            .Display
            Set myAttachments = OutlookItem.Attachments
                myAttachments.Add wbStr, olByValue, 1, "workbook"
            .to = Dic(Pin)
            .Save
        End With
    Set OutlookItem = Nothing
Next k
Application.ScreenUpdating = True
'-----------------------Release Memory-------------------------------
Set OutlookApp = Nothing
Set Dic = Nothing
End Sub

'关于EXCEL转Html，不可开启R1C1格式，不然会出错
Public Function RangeToHTML(rng, sAddress$)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim uRng
    TempFile = sAddress & ".htm"

'    rng.Copy
    '新建文件，另存为html
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1, 1).Resize(UBound(rng), UBound(rng, 2)) = rng
        .Cells.Columns.AutoFit
'        .UsedRange.Copy
'        .Cells(1).PasteSpecial Paste:=8
'        .Cells(1).PasteSpecial xlPasteValues, , False, False
'        .Cells(1).PasteSpecial xlPasteFormats, , False, False
'        .Cells(1).Select
'        Application.CutCopyMode = False
'        On Error Resume Next
'        .DrawingObjects.Visible = True
'        .DrawingObjects.Delete
'        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    'Read all data from htm file into RangetoHtml
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangeToHTML = ts.ReadAll
    ts.Close
    RangeToHTML = Replace(RangeToHTML, "align=center x:publishsource=", "align=left x:publishsource=")

    TempWB.Close savechanges:=False
'Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

'获取相关数据
Function Get_Data_From_Array(arr, ByVal Pin$, c_Date, b_Date)
Dim i, m
Dim Sk$
Dim x_Date As Date
Dim out(1 To 100, 1 To 9)
m = 1: i = 1
'标题
out(m, 1) = arr(i, 1)
out(m, 2) = arr(i, 2)
out(m, 3) = arr(i, 6)
out(m, 4) = arr(i, 9)
out(m, 5) = arr(i, 10)
out(m, 6) = arr(i, 13)
out(m, 7) = arr(i, 11)
out(m, 8) = arr(i, 12)
out(m, 9) = arr(i, 14)
For i = 2 To UBound(arr)
    Sk = arr(i, 2)      'PIN
    If Sk = Pin Then
        x_Date = String_2_Date(arr(i, 1))  'Date
        If x_Date <= c_Date And x_Date >= b_Date Then
            m = m + 1
            out(m, 1) = arr(i, 1)
            out(m, 2) = arr(i, 2)
            out(m, 3) = arr(i, 6)
            out(m, 4) = arr(i, 9)
            out(m, 5) = arr(i, 10)
            out(m, 6) = arr(i, 13)
            out(m, 7) = arr(i, 11)
            out(m, 8) = arr(i, 12)
            out(m, 9) = arr(i, 14)
        End If
    End If
Next i
If m = 1 Then Exit Function
Get_Data_From_Array = out
End Function
'字符日期转换字日期格式
Function String_2_Date(ByVal Str$) As Date
    a = Format(Str, "####-##-##")
    b = CDate(a)
    String_2_Date = b
End Function

具体文件可以从以下网盘下载

https://pan.baidu.com/s/1f29b4C3lFpyh4dQ8xVxIbw

转载于:https://my.oschina.net/tedzheng/blog/1927459