调用vba_VBA调用邮件

最新推荐文章于 2022-03-31 22:33:01 发布

袁冰涛

最新推荐文章于 2022-03-31 22:33:01 发布

阅读量1.1k

点赞数

文章标签：调用vba

本文链接：https://blog.csdn.net/weixin_36123285/article/details/112578538

版权

使用VBA在Excel中，根据筛选条件从邮件中下载附件，并介绍了如何通过VBA批量发送邮件。参考官方文档，实现了高效自动化处理电子邮件。

摘要由CSDN通过智能技术生成

需要配置outlook，才能调用Outlook.Application

下载邮件中的附件

Sub createMultiLevelFolder(sPath)
    '一次性创建多级文件夹
    arr = Split(sPath, "")
    For i = 0 To UBound(arr) - 1
        sPathTemp = arr(i) & "" & arr(i + 1)
        If Dir(sPathTemp, vbDirectory) = "" Then
            MkDir sPathTemp
        End If
        arr(i + 1) = sPathTemp
    Next
End Sub
Sub downloadEmail()
    '下载附件
    
    '如果outlook已经打开，直接取Outlook实例，如果没有打开，则创建一个Outlook实例
    On Error Resume Next
    Set myOlApp = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        Set myOlApp = CreateObject("Outlook.application")
    End If

    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    '后期绑定对象库的时候，GetDefaultFolder类型不能常量“olFolderInbox”表示
    '要用参考值来表示，olFolderInbox的参考值为6
    Set myFolder = myNameSpace.GetDefaultFolder(6)
    tdystart = Format(Range("B1"), "Short Date")
    tdyend = Format(Range("B2"), "Short Date")
    keyword = Range("B3")
    keySuffix = Range("B4")
    globalPath = Range("B5")
    fullPath = globalPath & Replace(tdystart, "-", "") & "-" & Replace(tdyend, "-", "")
    Call createMultiLevelFolder(fullPath) '创建文件夹

    For Each objitem In myFolder.Items
        tdReceived = Format(objitem.ReceivedTime, "Short Date") '邮件创建日期
        If tdReceived < tdystart Then Exit Sub  ' 如果创建日期小于开始日期，则结束程序
        If objitem.Class = olMail And _
            tdReceived >= tdystart And _
            tdReceived <= tdyend And _
            InStr(objitem.Subject, keyword) > 0 Then
            For Each myAttachment In objitem.Attachments   '//获得邮件的附件
                attFilename = myAttachment.Filename
                If attFilename Like keySuffix Then  '//判断附件的类型
                    myAttachment.SaveAsFile fullPath & "" & attFilename   '//保存附件
                End If
            Next
        End If
    Next
End Sub

Excel表中设置筛选条件，以及保存的路径

批量发送邮件

Sub SendMailEnvelope()
    Set objOL = New Outlook.Application
    maxRow = Range("A65536").End(xlUp).Row
    On Error Resume Next
    For i = 2 To maxRow
        FilePath = Cells(i, "E") '附件地址
        If Dir(FilePath) <> "" Then
            Cells(i, "F") = "发送成功"
        Else
            Cells(i, "F") = "发送失败，附件地址错误"
        End If
        Set objMail = objOL.CreateItem(olMailItem) '创建邮件对象
        With objMail
            .To = Cells(i, "B") '收件者
            .Subject = Cells(i, "C") '主题
            .HTMLBody = Cells(i, "D")   '正文本文
            .Attachments.Add FilePath '附件，如果你不需要发送附件，可以把这一句删掉即可，Excel中的第四列留空，不能删哦
            .Send
        End With
        Set objMail = Nothing   '销毁邮件对象
    Next
    Set objOL = Nothing
End Sub