Excel调用outlook发送邮件

EXCEL 免费编号：CODE-C229BC2D 下载次数：0 浏览次数：12 上传日期：2026-09-19

解决的问题

Excel VBA代码实现发送邮件和添加附件，需要注意的是电脑要安装outlook，并且做好第三方邮箱的连接。

代码内容

Sub 发送邮件()
    
    Dim OutApp As Object
    Dim OutMail As Object
 
 
    Dim crr(1 To 1000, 1 To 3)
    Set d = CreateObject("scripting.dictionary")
    '创建 Outlook 应用对象
     
    Range("D2:D1000").ClearContents
    arr = Range("a1").CurrentRegion

    For i = 2 To UBound(arr)
        wb = arr(i, 1)
        If d.exists(wb) = False And arr(i, 2) Like "*@*" And arr(i, 2) <> "" Then
            js = js + 1
            d.Add wb, arr(i, 2)
            crr(js, 1) = arr(i, 1)
            crr(js, 2) = arr(i, 2)
            crr(js, 3) = arr(i, 3)
        ElseIf arr(i, 2) Like "*@*" = False Or arr(i, 2) = "" Then
            Cells(i, 4) = "邮箱地址不正确"
            MsgBox "第" & i & "行的邮箱地址异常，所有邮件均未发送！程序退出，请修改后再运行程序！"
            Exit Sub
        End If
    Next
    
    

    
    For i = 1 To js
       
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
           
            
            With OutMail
                .To = crr(i, 2)
                .Subject = crr(i, 1) & " 收支明细表"
                .Attachments.Add crr(i, 3)
                .HTMLBody = "<html><body>" & Cells(1, 7) & "<br>" & Cells(1, 8) & "<br>" & Cells(2, 6) & Cells(2, 7) & "<br>" & Cells(3, 6) & Cells(3, 7) & "<br>" & Cells(4, 6) & Cells(4, 7) _
                    & "<br>" & Cells(5, 6) & Cells(5, 7) & "<br>" & Cells(6, 6) & Cells(6, 7) & "<br>" & Cells(7, 6) & Cells(7, 7) & "<br>" & Cells(8, 6) & Cells(8, 7) & "</body></html>"
                .Send
            End With
            Cells(i + 1, 4) = "已发送"
            Set OutMail = Nothing
            Set OutApp = Nothing

    Next
    MsgBox "邮件发送完毕！"
End Sub