利用VBA操作OutLook批量发送工资条

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

 

 

 

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

 

 

>>>>

发送邮件完整模板

 

 

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

 

 QQ邮箱发送效果

 

 

这两种批量发送邮件的方法基本能满足九成以上人的需求，再复杂的，不再深入研究。