从电子邮件中自动下载并保存附件到Excel

2 回答

• 0

  要添加到@ Om3r响应，您可以将此代码（未经测试）添加到 ThisOutlookSession 模块：

  Private WithEvents objNewMailItems As Outlook.Items
  Dim WithEvents TargetFolderItems As Items
  
  Private Sub Application_Startup()
  
      Dim ns As Outlook.NameSpace
  
      Set ns = Application.GetNamespace("MAPI")
      'Update to the correct Outlook folder.
      Set TargetFolderItems = ns.Folders.item("Mailbox - Luis") _
                                .Folders.item("Inbox") _
                                .Folders.item("Lighting Emails").Items
  
  End Sub
  
  Sub TargetFolderItems_ItemAdd(ByVal item As Object)
      SaveAtmt_ExportToExcel item
  End Sub
  

  这将监视Lighting Emails文件夹（或您选择的任何文件夹），并在电子邮件到达该文件夹时执行 SaveAtmt_ExportToExcel 过程 .

  这意味着Excel将为每封电子邮件打开和关闭 . 它还会中断你正在做的其他任何事情来打开Excel并执行 - 所以可能会想要更新所以它只打开一次Excel并运行Outlook规则将电子邮件放在正确的文件夹中，而不是一直打开 .

  回复于 2024-04-24T05:36:44+08:00
• 1

  试试这种方式......

  更新 SaveFolder = "c:\temp\" 和 Workbooks.Open("C:\Temp\Book1.xlsx")

  在Outlook 2010上测试过

  Public Sub SaveAtmt_ExportToExcel(Item As Outlook.MailItem)
      Dim Atmt As Outlook.Attachment
      Dim SaveFolder As String
      Dim DateFormat As String
  
      Dim strID As String, olNS As Outlook.NameSpace
      Dim olMail As Outlook.MailItem
      Dim strFileName As String
  
      '~~> Excel Variables
      Dim oXLApp As Object, oXLwb As Object, oXLws As Object
      Dim lRow As Long
      Dim i As Long
  
      SaveFolder = "c:\temp\"
      DateFormat = Format(Now, "yyyy-mm-dd H mm")
  
      For Each Atmt In Item.Attachments
          Atmt.SaveAsFile SaveFolder & "\" & DateFormat & " " & Atmt.DisplayName
      Next
  
  
      strID = Item.EntryID
      Set olNS = Application.GetNamespace("MAPI")
      Set olMail = olNS.GetItemFromID(strID)
  
      '~~> Establish an EXCEL application object
      On Error Resume Next
      Set oXLApp = GetObject(, "Excel.Application")
  
      '~~> If not found then create new instance
      If Err.Number <> 0 Then
          Set oXLApp = CreateObject("Excel.Application")
      End If
      Err.Clear
      On Error GoTo 0
  
      '~~> Show Excel
      oXLApp.Visible = True
  
      '~~> Open the relevant file
      Set oXLwb = oXLApp.Workbooks.Open("C:\Temp\Book1.xlsx")
  
      '~~> Set the relevant output sheet. Change as applicable
      Set oXLws = oXLwb.Sheets("Multiplier")
  
      lRow = oXLws.Range("A" & oXLws.Rows.Count).End(xlUp).Row + 1
  
      '~~> Write to outlook
      With oXLws
  
          lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
  
          Dim MyAr() As String
  
          MyAr = Split(olMail.body, vbCrLf)
  
          For i = LBound(MyAr) To UBound(MyAr)
              .Range("A" & lRow).Value = MyAr(i)
              lRow = lRow + 1
          Next i
          '
      End With
  
      '~~> Close and Clean
      oXLwb.Close (True)
      oXLApp.Quit
  
      Set oXLws = Nothing
      Set oXLwb = Nothing
      Set oXLApp = Nothing
      Set olMail = Nothing
      Set olNS = Nothing
      Set Atmt = Nothing
  End Sub
  

  回复于 2024-04-24T05:36:44+08:00