网上看到的一个例子，需要将以下表格根据内容将近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
具体文件可以从以下网盘下载
/s/1f29b4C3lFpyh4dQ8xVxIbw
