如何用VBA获取指定日期（如当日）的所有XML文件并邮件发送

以下是修改后的代码，可筛选出指定日期（默认当日）的所有XML文件，并通过Outlook全部作为附件发送：

Sub SendEmail_Demo()
    'Declare the variables
    Dim MyPath As String
    Dim MyFile As String
    Dim TargetDate As Date
    Dim LMD As Date
    Dim AttachFiles As Collection '存储符合条件的文件
    
    '指定目标日期（这里设为当日，可自行修改为其他日期）
    TargetDate = Date
    
    'Specify the path to the folder
    MyPath = "..................\XML\"
    
    'Make sure that the path ends in a backslash
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
    
    '初始化集合用于存储符合条件的文件
    Set AttachFiles = New Collection
    
    'Get the first XML file from the folder
    MyFile = Dir(MyPath & "*.xml", vbNormal) '去掉多余的*，避免匹配非XML文件
    
    'If no files were found, exit the sub
    If Len(MyFile) = 0 Then
        MsgBox "No files were found...", vbExclamation
        Exit Sub
    End If
    
    'Loop through each XML file in the folder
    Do While Len(MyFile) > 0
        'Assign the date/time of the current file to a variable
        LMD = FileDateTime(MyPath & MyFile)
        
        '判断文件日期是否等于目标日期（只取日期部分，忽略时间）
        If DateValue(LMD) = TargetDate Then
            AttachFiles.Add MyPath & MyFile '添加到集合
        End If
        
        'Get the next XML file from the folder
        MyFile = Dir
    Loop
    
    '如果没有符合条件的文件，提示并退出
    If AttachFiles.Count = 0 Then
        MsgBox "No XML files found for the target date.", vbExclamation
        Exit Sub
    End If
    
    Dim OutlookApp As Outlook.Application
    Dim OutlookMail As Outlook.MailItem
    
    Set OutlookApp = New Outlook.Application
    Set OutlookMail = OutlookApp.CreateItem(olMailItem)
    
    With OutlookMail
        .BodyFormat = olFormatHTML
        .Display
        .HTMLBody = "Hi demo"
        .To = "myEmail.com" '修正拼写错误
        .Subject = "Test demo - All XML files for " & Format(TargetDate, "yyyy-mm-dd")
        
        '遍历集合添加所有附件
        Dim file As Variant
        For Each file In AttachFiles
            .Attachments.Add file
        Next file
        
        .Send
    End With
    
    '释放对象
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    Set AttachFiles = Nothing
End Sub

关键修改点： #

• 新增AttachFiles集合，用于存储所有符合日期条件的文件路径，替代原有的单个LatestFile变量
• 新增TargetDate变量，指定要筛选的日期（默认设为当日Date，可修改为任意日期如DateSerial(2024,5,20)）
• 修改文件筛选逻辑：用DateValue(LMD) = TargetDate判断文件的日期部分是否匹配目标日期，忽略时间差异
• 遍历集合批量添加附件，而非仅添加单个文件
• 修正原代码中myEmial.com的拼写错误
• 优化邮件主题，添加目标日期便于识别
• 增加无符合条件文件时的提示逻辑
• 添加对象释放代码，避免内存泄漏

内容的提问来源于stack exchange，提问作者Konstantin Petkov