VBA操作OutLook批量发送工资条

VBA操作OutLook
最近帮朋友做了类似功能，利用VBA操作OutLook批量发送工资条，极大节省了人力。正好来总结一下，希望为大家所用。（本篇文章默认读者电脑已经可以进行手动发送邮件，不讲解OutLook如何配置邮箱，设置发件人等信息）

先扔框架模板：VBA操作OutLook有一套固定的代码模板，可根据具体需求修改即可。

>>>>发送邮件完整模板

[/code][code]Sub SendMail()
Set myOlApp = CreateObject("Outlook.Application")'//后期绑定
Set objMail = myOlApp.CreateItem(olMailItem)'新建一封邮件
With objMail
.To = "2199648674@qq.com"'//收件人
.Subject = "邮件主题" '//就是邮件标题
.Body = "邮件正文内容" '//正文具体内容
.cc = "vbatoday@163.com" '//邮件抄送人
'.BodyFormat = olFormatHTML '//设置邮件格式是否html 格式的，注意，在Excel中引用OutLook的时候，该参数要写成数字2
'.HTMLBody =RangetoHTML(单元格对象) '//RangetoHTML是自定义函数，见下面。
.Attachments.Add "C:\Users\Administrator\Desktop\派送单.xlsx" '//添加附件
.Display '//刷新显示效果的作用
.Send'//发送
End With
End Sub

复制代码

几点注意事项：
①Display作用是把上述所有操作完成后，刷新显示OutLook软件界面，可以理解为预览。可省略。
②.BodyFormat = olFormatHTML这块注意，因为是Excel操作OutLook，所以不能直接写属性名称，而要替换成数字代号，否则会出错。正确写法：.BodyFormat = 2
这个2怎么得到的？去OutLook软件里面，Msgbox olFormatHTML。Word VBA也讲过类似注意点。
③BodyFormat=2和HTMLBody是同时出现的。

>>>>将表格内容转换为html格式的自定义函数
！！！需要注意的是：Excel默认情况下，网格线不会被识别。只有人为设置了边框线后，用该函数转化过，才会显示边框线。

Public Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.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
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
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

复制代码

直接上实战例子：案例里面邮箱均是作者小号，欢迎骚扰
。

>>>>以附件形式发送工资条

把每个人的工资条导出为图片，添加为附件发送。

模板页纯粹是为了粘贴数据导出图片，没有特殊含义

Sub SendMail()
Set sht1 = Worksheets("邮件页")
Set sht2 = Worksheets("模板页")
sht1.Range("a1:d1").Copy sht2.Range("a1")
For Each rng In sht1.Range("a2:a" & sht1.Cells(Rows.Count, 1).End(3).Row)
rng.Resize(1, 4).Copy sht2.Range("a2")
Set rng2 = sht2.Range("a1:d2")
sht2.Range("a1:d2").CopyPicture Appearance:=xlScreen, Format:=xlBitmap '把选择范围内容转化为截屏图片信息
With ActiveSheet.ChartObjects.Add(0, 0, rng2.Width + 1, rng2.Height + 1).Chart '在A1处按图片尺寸稍大建立1个空白图表对象
.Paste '把刚才截屏的图片信息粘贴上去
.Export ThisWorkbook.Path & "\" & rng & ".png", "PNG" '按指定图片路径及名称导出png格式图片……这个对于纯数据工作表来说更好
.Parent.Delete '删去该临时增加的图表对象
End With
Next
Set myOlApp = CreateObject("Outlook.Application")
Set objMail = myOlApp.CreateItem(olMailItem)
For a = 2 To sht1.Cells(Rows.Count, 1).End(3).Row
Set objMail = myOlApp.CreateItem(olMailItem)
With objMail
.To = sht1.Cells(a, 5).Value '//收件人
.Subject = "工资明细" '//主题
.Body = "这是您本月的工资明细" '//正文具体内容
.Attachments.Add ThisWorkbook.Path & "\" & sht1.Cells(a, 1) & ".png" '//添加附件
.send
End With
Set objMail = Nothing
Next
MsgBox "发送完成！"
End Sub

复制代码

QQ邮箱发送效果

>>>>以HTML形式发送工资条

Sub SendMail2()
Set sht1 = Worksheets("邮件页")
Set sht2 = Worksheets("模板页")
sht1.Range("a1:d1").Copy sht2.Range("a1")
For Each rng In sht1.Range("a2:a" & sht1.Cells(Rows.Count, 1).End(3).Row)
rng.Resize(1, 4).Copy sht2.Range("a2")
Set myOlApp = CreateObject("Outlook.Application")
Set objMail = myOlApp.CreateItem(olMailItem)
With objMail
.To = Cells(rng.Row, 5).Value '//收件人
.Subject = "工资明细" '//主题
.BodyFormat = 2
.HTMLBody = RangetoHTML(sht2.Range("a1:d2"))
.display
.send
End With
Set objMail = Nothing
Next
MsgBox "发送完成！"
End Sub
Public Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.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
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
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

复制代码