Vba 下载附件（未找到附件）

我从中得到了一个代码，我正在根据需要调整它。我的需求很简单：如果它有我正在跟踪的每日跟踪器的名称，我需要下载它（因为它每天都随着

格式（现在）

而变化）。问题是它找不到附件

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

如果我用

oOlItm.Display

替换

ElseIf

到

Next

部分，代码可以找到电子邮件，但不会下载附件

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

子附件下载（）
常量olFolderInbox为整数=6
“~~>附件的路径
Const AttachmentPath As String=“C:\TEMP\TestExcel”
作为对象的Dim oOlAp
把乌龙当作对象
作为对象的Dim oOlInb
作为对象的Dim oOlItm
作为对象的Dim oOlAtch
将NewFileName设置为字符串
NewFileName=“Daily Tracker”和格式（现在为“dd/MM/yyyyy”）
设置oOlAp=GetObject（，“Outlook.application”）
设置oOlns=oOlAp.GetNamespace（“MAPI”）
设置oOlInb=oOlns.GetDefaultFolder（olFolderInbox）
对于oOlInb.项中的每个oOlItm
如果InStr（oOlItm.Subject，NewFilename））为0，则
ElseIf oOlItm.Attachments.Count 0然后
对于oOlItm.附件中的每个oOlAtch
oOlAtch.SaveAsFile（附件路径）
退出
下一个
其他的
MsgBox“未找到任何附件”
如果结束
退出
下一个
端接头

电邮：

---

这应该适合您：

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

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

---

可能将

oOlAtch.SaveAsFile（AttachmentPath）

更改为类似于

oOlAtch.SaveAsFile（AttachmentPath&“\”&NewFileName&“.xls”的内容

-您只是指定了路径，而不是文件名。但是如果我没有指定新的文件名，它不应该与文件名一起下载吗？我尝试了您的建议，但也没有找到附件。我正在上载电子邮件的打印屏幕。您的代码未编译。

说明中有一个大括号（oOlItm.Subject，NewFilename））

。我也不清楚您的

If

ElseIf

构造。如果主题包含

新文件名

您什么也不做，否则如果附件计数大于0，则您尝试读取附件，如果主题既不包含

新文件名

也不包含大于0的附件，则您的邮件“未找到附件”？刚刚实现-

“每日跟踪器”和格式（现在为“dd/MM/yyyy”）

将创建文件名为

Daily Tracker 30/10/2015

。文件名中不能有斜杠。@DarrenBartrup Cook观察得很好。我已将格式更改为

dd_MM_yyyyy

。嘿，Darren。感谢您的帮助。它下载了该文件，但下载了48个不同的文件，呵呵。可能是因为该文件与电子邮件？我们如何才能将其限制为.xlsx文件？它可能下载了您电子邮件签名中的任何徽标等。我将进行快速重写。好的，我已经更新了它-它现在在保存文件之前查看文件扩展名-

如果GetExt（oOlAtch.FileName）=“xlsx”然后

很好，伙计！非常感谢。工作很有魅力。已再次更新，以包含一种从Outlook自动执行的方法。