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

2024-02-29 09:12| 来源: 网络整理| 查看: 265

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 = 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

【本文地址】

公司简介

联系我们