如何修改Excel VBA代码实现按发送时间下载指定发件人当日首个Outlook邮件附件

Got it, let's tackle this problem. The goal is to only download the first xlsm attachment from Ahmed's first email sent today, instead of grabbing all his attachments from every matching email. Here are the key adjustments you need to make to your VBA code, plus the full modified version:

Key Adjustments #

• Add a flag to track if we've already retrieved the first valid attachment
  • Declare a boolean variable at the top to avoid processing more emails once we've found our target. Initialize it to False, and flip it to True after saving the first attachment.
• Sort emails by send time
  • Sort the inbox items by the SentOn field in ascending order (earliest first) so we process Ahmed's first email of the day before any others.
• Filter for today's emails only
  • Add a check to ensure we only consider emails Ahmed sent on the current date.
• Exit the loop immediately after saving the first attachment
  • Once we've saved the target file, stop looping through additional emails to avoid unnecessary processing.

Modified Full Code #

Sub DATA()
    Dim ol As Object 'Outlook.Application
    Dim ns As Object 'Outlook.Namespace
    Dim fol As Object 'Outlook.Folder
    Dim i As Object
    Dim mi As Object 'Outlook.MailItem
    Dim at As Object 'Outlook.Attachment
    Dim fso As Object 'Scripting.FileSystemObject
    Dim dir As Object 'Scripting.Folder
    Dim dirName As String
    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFile As Object
    Dim f As Integer ' change 1
    Dim inboxFol As Object 'Outlook.Folder
    Dim subFol As Object 'Outlook.Folder
    ' NEW: Flag to track if we've found the first valid attachment
    Dim foundFirst As Boolean
    foundFirst = False
    
    'Some Set Ups
    Set fso = CreateObject(Class:="Scripting.FileSystemObject")
    Set ol = CreateObject(Class:="Outlook.Application")
    Set ns = ol.GetNamespace("MAPI")
    
    Set inboxFol = ns.GetDefaultFolder(6) 'olFolderInbox
    Set subFol = inboxFol.Folders("Operation")
    
    ' NEW: Sort inbox items by send time (ascending = earliest first)
    inboxFol.Items.Sort "SentOn", 1
    
    'Finding the search item from Outlook Inbox
    For Each i In inboxFol.Items
        ' Exit loop early if we already found the first attachment
        If foundFirst Then Exit For
        
        If i.Class = 43 Then
            Set mi = i
            ' MODIFIED: Add date check for today's emails + sender check + attachment count
            If mi.Attachments.Count > 0 And InStr(mi.SenderName, "Ahmed") And DateValue(mi.SentOn) = Date Then
                dirName = "C:\Work Area"
                If fso.FolderExists(dirName) Then
                    Set dir = fso.GetFolder(dirName)
                Else
                    Set dir = fso.Createfolder(dirName)
                End If
                
                'Saving Attachment to a folder
                For Each at In mi.Attachments
                    If Right(at.Filename, 4) = "xlsm" Then
                        at.SaveAsFile dir.Path & "\" & "Daily Work Data.xlsm"
                        ' NEW: Mark as found and exit attachment loop (no need for other attachments in this email)
                        foundFirst = True
                        Exit For
                    End If
                Next at
                
                mi.UnRead = False
                mi.Move subFol
            End If
        End If
    Next i
    
    'Setting Folder
    If foundFirst Then ' Only open if we actually downloaded a file
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        Set oFolder = oFSO.GetFolder("C:\Work Area")
        CreateObject("shell.application").Open ("C:\Work Area\Daily Work Data.xlsm")
    Else
        MsgBox "No valid xlsm attachment from Ahmed found today."
    End If
End Sub

Notes on the Changes #

• The foundFirst flag ensures we stop processing as soon as we save the first valid attachment.
• Sorting by SentOn guarantees we get Ahmed's earliest email of the day first.
• The DateValue(mi.SentOn) = Date check filters out any older emails from Ahmed.
• We added a check to only open the file if we actually downloaded it, plus a message box for cases where no matching attachment exists.

内容的提问来源于stack exchange，提问作者Shameer Kuppanath