VBA自動發送郵件+內容+附件

網上看到的一個例子，須要將如下表格根據內容將近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