下载附件(附件未找到)

Question

我有一个来自here的代码，我正在根据我的需要对它进行修改。我的需求很简单:如果它有我正在跟踪的Daily的名称，我需要它下载(因为它每天都会随着Format(Now)而变化)。问题是它没有找到附件。

如果我将ElseIf替换为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收件箱中创建一个新文件夹，并设置规则，以便在电子邮件到达时将其移动到此文件夹。然后，您可以编写代码来查看该文件夹，并在文件到达时立即保存它。

将此代码放入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中创建一个新模块，并将此代码放入其中。这将创建一个消息盒，它不会停止您正在做的任何事情。

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