Question

我有here的代码，我正在调整它以满足我的需要。我的需求非常简单：如果它具有我跟踪的每日跟踪器的名称（因为它每天随Format(Now)更改），我需要下载它。问题是它没有找到附件。

如果我将ElseIf替换为Next的{{1}}部分，但代码可以找到该电子邮件，但不会下载附件。

oOlItm.Display

电子邮件：

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

下载附件（未找到附件）

1 个答案: