（分享）outlook调用VBA群发工资条分享

木子Lee2018

在论坛找的代码群发工资条一直出错，经更改后，测试已经没有问题，分享给需要的小伙伴，供大家一起学习 outlook群发工资条代码.zip (36.69 KB, 下载次数: 23)

2019-3-19 10:40 上传

点击文件名下载附件

   Sub 全自动发送邮件()

    Dim myOlApp As Object
    Dim myitem As Object
    Dim i As Integer, j As Integer
    Dim strg As String
    Dim atts As Object
    Dim mycc As Object
    Dim myfile As String

    Set myOlApp = CreateObject("Outlook.Application")

    '设置对Sheet1工作表进行操作，可自行修改
    With Sheets("Sheet1")
        i = 2

        Do While .Cells(i, 2) <> ""
                   '设置调用Outlook来发送邮件
           Set myitem = myOlApp.CreateItem(0)
           Set atts = myitem.Attachments
           '收件人邮箱地址调用了第3列邮箱的数据
           receiver = Cells(i, 2)
           SubjectText = Cells(i, 1) & .Cells(i, 3)
            myitem.To = receiver
           '邮件标题调用了第2列姓名、第4列标题的数据
            myitem.Subject = SubjectText

             myitem.Body = .Cells(i, 1) & "，你好！" & vbNewLine & vbNewLine & vbNewLine & .Cells(i, 4) & "，具体请看附件。" & vbNewLine & vbNewLine & vbNewLine & "祝你工作开心！"

            myfile = Dir(ThisWorkbook.Path & "\*" & .Cells(i, 1) & ".*")


            Do Until myfile = ""
                myitem.Attachments.Add ThisWorkbook.Path & "\" & myfile, 1
                myfile = Dir

            Loop


                        '预览，如果想直接发送，把.display改为.send
            myitem.display

            i = i + 1
            strg = ""
        Loop
    End With

    Set myitem = Nothing

    End Sub