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

时间:2012-08-02 15:55:26

标签: excel vba excel-vba outlook email-attachments

我正在尝试下载,然后使用Excel中的VBA在Outlook电子邮件中打开Excel电子表格附件。 我怎么能:

  1. 下载来自Outlook收件箱中第一封电子邮件(最新电子邮件)的唯一附件
  2. 在具有指定路径的文件中保存附件(例如:“C:...”)
  3. 使用以下代码重命名附件名称:当前日期 + 上一个文件名
  4. 将电子邮件保存到其他文件夹中,其路径如“C:...”
  5. 将Outlook中的电子邮件标记为“已读”
  6. 在Excel中打开 Excel附件
  7. 我还希望能够将以下内容保存为分配给各个变量的单个字符串:

    • 发件人电子邮件地址
    • 收到日期
    • 发送日期
    • 主题
    • 电子邮件的消息

    虽然最好在单独的问题中提问/自己寻找。

    我目前拥有的代码来自其他在线论坛,可能不是很有帮助。但是,这里有一些我正在研究的点点滴滴:

    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
    

2 个答案:

答案 0 :(得分:64)

我可以一次性给你完整的代码,但这对你学习不会有帮助;)所以让我们分解你的请求,然后我们将1比1解决它们。这将是一个非常长的帖子所以耐心等待:)

总共有5个部分将覆盖所有7个(是7而不是6)点,因此您不必为第7个点创建新问题。


PART - 1

  1. 创建与Outlook的连接
  2. 检查是否有未读电子邮件
  3. 检索Sender email AddressDate receivedDate SentSubjectThe message of the email
  4. 等详细信息

    请参阅此代码示例。我迟到了Excel中的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
    

    因此,请注意您的请求,该请求涉及在变量中存储详细信息。


    PART - 2

    现在转到下一个请求

    1. 从我的Outlook收件箱中的第一封电子邮件(最新的电子邮件)下载唯一的附件
    2. 将附件保存在具有指定路径的文件中(例如:“C:...”)
    3. 使用:当前日期+上一个文件名
    4. 重命名附件名称

      请参阅此代码示例。我再次使用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
      

      PART - 3

      继续下一个请求

      1. 将电子邮件保存到其他文件夹中,其路径如“C:...”
      2. 请参阅此代码示例。这会将电子邮件保存为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
        

        PART - 4

        继续下一个请求

        1. 将Outlook中的电子邮件标记为“已读”
        2. 请参阅此代码示例。这会将电子邮件标记为read

          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
          

          PART - 5

          继续下一个请求

          1. 在Excel中打开Excel附件
          2. 如上所示下载文件/附件后,请使用以下代码中的路径打开文件。

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

答案 1 :(得分: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