从Outlook下载附件并在Excel中打开

Question

从Outlook下载附件并在Excel中打开

vbaexceloutlookemail-attachments

32

我正在尝试使用Excel VBA下载并打开Outlook电子邮件中的Excel电子表格附件。我该如何：

下载Outlook收件箱中最新电子邮件的唯一附件
将附件保存到指定路径的文件中（例如：“C：...”）
将附件名称重命名为：当前日期+ 先前的文件名
将邮件保存到具有“C：...”路径的不同文件夹中
将Outlook中的邮件标记为“已读”
在Excel中打开Excel附件

此外，我还想能够将以下内容保存为单独的字符串并分配给单独的变量：

发件人电子邮件地址
接收日期
发送日期
主题
邮件正文

虽然这可能更好地作为一个单独的问题来询问/自己查找。

我目前拥有的代码来自在线论坛，可能没有太大帮助。但是，这里是我正在处理的一些部分：

Sub SaveAttachments()
    Dim olFolder As Outlook.MAPIFolder
    Dim att As Outlook.Attachment
    Dim strFilePath As String
    Dim fsSaveFolder As String

    fsSaveFolder = "C:\test\"

    strFilePath = "C:\temp\"

    Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

    For Each msg In olFolder.Items
        While msg.Attachments.Count > 0
            bflag = False
            If Right$(msg.Attachments(1).Filename, 3) = "msg" Then
                bflag = True
                msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg
                Set msg2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg)
            End If
            sSavePathFS = fsSaveFolder & msg2.Attachments(1).Filename


    End If
End Sub

- Paolo Bernasconi

2个回答

1

(Excel vba)

感谢Sid的代码（借鉴了你的代码）。。我今天遇到了这种情况。这是我的代码。下面的代码保存附件、邮件和邮件信息..所有的功劳归功于 Sid

Tested 

Sub mytry()
Dim olapp As Object
Dim olmapi As Object
Dim olmail As Object
Dim olitem As Object
Dim lrow As Integer
Dim olattach As Object
Dim str As String

Const num As Integer = 6
Const path As String = "C:\HP\"
Const emailpath As String = "C:\Dell\"
Const olFolderInbox As Integer = 6

Set olp = CreateObject("outlook.application")
Set olmapi = olp.getnamespace("MAPI")
Set olmail = olmapi.getdefaultfolder(num)

If olmail.items.restrict("[UNREAD]=True").Count = 0 Then

    MsgBox ("No Unread mails")

    Else

        For Each olitem In olmail.items.restrict("[UNREAD]=True")
            lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1

            Range("A" & lrow).Value = olitem.Subject
            Range("B" & lrow).Value = olitem.senderemailaddress
            Range("C" & lrow).Value = olitem.to
            Range("D" & lrow).Value = olitem.cc
            Range("E" & lrow).Value = olitem.body

            If olitem.attachments.Count <> 0 Then

                For Each olattach In olitem.attachments

                    olattach.SaveAsFile path & Format(Date, "MM-dd-yyyy") & olattach.Filename

                Next olattach

            End If
    str = olitem.Subject
    str = Replace(str, "/", "-")
    str = Replace(str, "|", "_")
    Debug.Print str
            olitem.SaveAs (emailpath & str & ".msg")
            olitem.unread = False
            DoEvents
            olitem.Save
        Next olitem

End If

ActiveSheet.Rows.WrapText = False

End Sub

- Sathish Kothandam

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Siddharth Rout · Accepted Answer

我可以一次性给你完整的代码，但这并不能帮助你从中学习。所以，让我们分开处理你的请求，然后逐个解决。这将是一个非常长的帖子，所以请耐心等待。

总共有5个部分，涵盖了所有7个（是7个而不是6个）点，因此您不必为第7个点创建一个新问题。

PART-1

1. 创建与Outlook的连接 2. 检查是否有未读邮件 3. 检索发件人电子邮件地址、收到日期、发送日期、主题和邮件内容等详细信息。

请参考以下代码示例。我正在使用Excel中的latebinding与Outlook进行连接，然后检查是否有任何未读项目，如果有，我会检索相关详细信息。

Const olFolderInbox As Integer = 6

Sub ExtractFirstUnreadEmailDetails()
    Dim oOlAp As Object, oOlns As Object, oOlInb As Object
    Dim oOlItm As Object

    '~~> Outlook Variables for email
    Dim eSender As String, dtRecvd As String, dtSent As String
    Dim sSubj As String, sMsg As String

    '~~> Get Outlook instance
    Set oOlAp = GetObject(, "Outlook.application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

    '~~> Check if there are any actual unread emails
    If oOlInb.Items.Restrict("[UnRead] = True").Count = 0 Then
        MsgBox "NO Unread Email In Inbox"
        Exit Sub
    End If

    '~~> Store the relevant info in the variables
    For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")
        eSender = oOlItm.SenderEmailAddress
        dtRecvd = oOlItm.ReceivedTime
        dtSent = oOlItm.CreationTime
        sSubj = oOlItm.Subject
        sMsg = oOlItm.Body
        Exit For
    Next

    Debug.Print eSender
    Debug.Print dtRecvd
    Debug.Print dtSent
    Debug.Print sSubj
    Debug.Print sMsg
End Sub

那么这就解决了您的要求，关于将细节存储在变量中的问题。

第二部分

现在进入您的下一个请求

从我的Outlook收件箱的第一封邮件（最新的邮件）中下载唯一的附件
使用指定路径（例如：“C：...”）将附件保存到文件中
将附件名称重命名为：当前日期+之前的文件名

请参见此代码示例。我再次从Excel晚期连接Outlook，然后检查是否有未读项目，如果有，则进一步检查它是否有附件，如果有，则将其下载到相关文件夹。

Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\"

Sub DownloadAttachmentFirstUnreadEmail()
    Dim oOlAp As Object, oOlns As Object, oOlInb As Object
    Dim oOlItm As Object, oOlAtch As Object

    '~~> New File Name for the attachment
    Dim NewFileName As String
    NewFileName = AttachmentPath & Format(Date, "DD-MM-YYYY") & "-"

    '~~> Get Outlook instance
    Set oOlAp = GetObject(, "Outlook.application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

    '~~> Check if there are any actual unread emails
    If oOlInb.Items.Restrict("[UnRead] = True").Count = 0 Then
        MsgBox "NO Unread Email In Inbox"
        Exit Sub
    End If

    '~~> Extract the attachment from the 1st unread email
    For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")
        '~~> Check if the email actually has an attachment
        If oOlItm.Attachments.Count <> 0 Then
            For Each oOlAtch In oOlItm.Attachments
                '~~> Download the attachment
                oOlAtch.SaveAsFile NewFileName & oOlAtch.Filename
                Exit For
            Next
        Else
            MsgBox "The First item doesn't have an attachment"
        End If
        Exit For
    Next
 End Sub

第三部分

接下来是您的下一个请求

将电子邮件保存到路径为“C：...”的不同文件夹中

请参考以下代码示例。这会将电子邮件保存到 C:\ 中。

Const olFolderInbox As Integer = 6
'~~> Path + Filename of the email for saving
Const sEmail As String = "C:\ExportedEmail.msg"

Sub SaveFirstUnreadEmail()
    Dim oOlAp As Object, oOlns As Object, oOlInb As Object
    Dim oOlItm As Object, oOlAtch As Object

    '~~> Get Outlook instance
    Set oOlAp = GetObject(, "Outlook.application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

    '~~> Check if there are any actual unread emails
    If oOlInb.Items.Restrict("[UnRead] = True").Count = 0 Then
        MsgBox "NO Unread Email In Inbox"
        Exit Sub
    End If

    '~~> Save the 1st unread email
    For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")
        oOlItm.SaveAs sEmail, 3
        Exit For
    Next
End Sub

第四部分

接下来是您的下一个请求。

将Outlook中的电子邮件标记为“已读”

请参考以下代码示例。这将把电子邮件标记为已读。

Const olFolderInbox As Integer = 6

Sub MarkAsUnread()
    Dim oOlAp As Object, oOlns As Object, oOlInb As Object
    Dim oOlItm As Object, oOlAtch As Object

    '~~> Get Outlook instance
    Set oOlAp = GetObject(, "Outlook.application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

    '~~> Check if there are any actual unread emails
    If oOlInb.Items.Restrict("[UnRead] = True").Count = 0 Then
        MsgBox "NO Unread Email In Inbox"
        Exit Sub
    End If

    '~~> Mark 1st unread email as read
    For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")
        oOlItm.UnRead = False
        DoEvents
        oOlItm.Save
        Exit For
    Next
 End Sub

第五部分

接下来是您的下一个请求。

在Excel中打开附件

一旦您像上面所示下载了文件/附件，然后使用该路径在以下代码中打开文件。

Sub OpenExcelFile()
    Dim wb As Workbook

    '~~> FilePath is the file that we earlier downloaded
    Set wb = Workbooks.Open(FilePath)
End Sub

我将这篇文章转化为了几篇博客文章（并提供更多解释），可以通过vba-excel中的第15、16和17项来访问。