下载附件（找不到附件）

我从这里得到了一个代码，并且正在为我的需要调整它。 我的需求非常简单：如果它具有我跟踪的日常跟踪器的名称（因为每天使用Format(Now)更改），我需要它下载。 问题是它没有find附件。

代码可以find电子邮件，如果我replaceElseIf到Next一部分oOlItm.Display ，但不会下载附件。

 Sub AttachmentDownload() Const olFolderInbox As Integer = 6 '~~> Path for the attachment Const AttachmentPath As String = "C:\TEMP\TestExcel" Dim oOlAp As Object Dim oOlns As Object Dim oOlInb As Object Dim oOlItm As Object Dim oOlAtch As Object Dim NewFileName As String NewFileName = "Daily Tracker " & Format(Now, "dd/MM/yyyy") Set oOlAp = GetObject(, "Outlook.application") Set oOlns = oOlAp.GetNamespace("MAPI") Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox) For Each oOlItm In oOlInb.Items If InStr(oOlItm.Subject, NewFilename)) <> 0 Then ElseIf oOlItm.Attachments.Count <> 0 Then For Each oOlAtch In oOlItm.Attachments oOlAtch.SaveAsFile (AttachmentPath) Exit For Next Else MsgBox "No attachments found" End If Exit For Next End Sub 

电子邮件：

Answer 1

这应该为你工作：

  Sub AttachmentDownload() Const olFolderInbox As Integer = 6 '~~> Path for the attachment Const AttachmentPath As String = "C:\TEMP\TestExcel" Dim oOlAp As Object Dim oOlns As Object Dim oOlInb As Object Dim oOlItm As Object Dim oOlAtch As Object Dim oOlResults As Object Dim x As Long Dim NewFileName As String NewFileName = "Daily Tracker " & Format(Now, "dd-MM-yyyy") 'You can only have a single instance of Outlook, so if it's already open 'this will be the same as GetObject, otherwise it will open Outlook. Set oOlAp = CreateObject("Outlook.Application") Set oOlns = oOlAp.GetNamespace("MAPI") Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox) 'No point searching the whole Inbox - just since yesterday. Set oOlResults = oOlInb.Items.Restrict("[ReceivedTime]>'" & Format(Date - 1, "DDDDD HH:NN") & "'") 'If you have more than a single attachment they'll all overwrite each other. 'x will update the filename. x = 1 For Each oOlItm In oOlResults If oOlItm.attachments.Count > 0 Then For Each oOlAtch In oOlItm.attachments If GetExt(oOlAtch.FileName) = "xlsx" Then oOlAtch.SaveAsFile AttachmentPath & "\" & NewFileName & "-" & x & ".xlsx" End If x = x + 1 Next oOlAtch End If Next oOlItm End Sub '---------------------------------------------------------------------- ' GetExt ' ' Returns the extension of a file. '---------------------------------------------------------------------- Public Function GetExt(FileName As String) As String Dim mFSO As Object Set mFSO = CreateObject("Scripting.FileSystemObject") GetExt = mFSO.GetExtensionName(FileName) End Function 

另一种方式是在Outlook中：

在Outlook收件箱中创build一个新文件夹，并设置一个规则，在到达时将电子邮件移动到该文件夹​​。 然后，您可以编写代码来观看此文件夹，并在文件到达时立即保存。

将此代码放在Outlook中的ThisOutlookSession模块内。

 Dim WithEvents TargetFolderItems As Items Const FILE_PATH As String = "C:\TEMP\TestExcel\" Private Sub Application_Startup() Dim ns As Outlook.NameSpace Set ns = Application.GetNamespace("MAPI") Set TargetFolderItems = ns.Folders.Item("Mailbox - Darren Bartrup-Cook") _ .Folders.Item("Inbox") _ .Folders.Item("My Email For Processing").Items End Sub Sub TargetFolderItems_ItemAdd(ByVal Item As Object) 'when a new item is added to our "watched folder" we can process it Dim olAtt As Attachment Dim i As Integer Dim sTmpFileName As String Dim objFSO As Object Dim sExt As String If Item.Attachments.Count > 0 Then Set objFSO = CreateObject("Scripting.FileSystemObject") For i = 1 To Item.Attachments.Count Set olAtt = Item.Attachments(i) sExt = objFSO.GetExtensionName(olAtt.FileName) If sExt = "xlsx" Then sTmpFileName = "Daily Tracker " & Format(Now, "dd-mm-yyyy") & ".xlsx" End If Item.UnRead = False olAtt.SaveAsFile FILE_PATH & sTmpFileName DoEvents Next End If Set olAtt = Nothing MsgPopup "A new attachment has been saved.", vbOKOnly, "New Daily Tracker" End Sub Private Sub Application_Quit() Dim ns As Outlook.NameSpace Set TargetFolderItems = Nothing Set ns = Nothing End Sub 

在Outlook中创build一个新的模块，并把这个代码放在那里。 这将创build一个消息框，不会停止你正在做的任何事情。

 Public Function MsgPopup(Optional Prompt As String, _ Optional Buttons As VbMsgBoxStyle = vbOKOnly, _ Optional Title As String, _ Optional SecondsToWait As Long = 0) As VbMsgBoxResult ' Replicates the VBA MsgBox() function, with an added parameter ' to automatically dismiss the message box after n seconds ' If dismissed automatically, this will return -1: NOT 'cancel' or the default button choice. ' Nigel Heffernan, 2006. This code is in the public domain. ' Uses late-binding: bad for performance and stability, useful for code portability ' The correct declaration is: Dim objWshell As IWshRuntimeLibrary.WshShell Dim objWshell As Object Set objWshell = CreateObject("WScript.Shell") MsgPopup = objWshell.Popup(Prompt, SecondsToWait, Title, Buttons) Set objWshell = Nothing End Function