修改Outlook宏：自动选取当日CSV文件并发送邮件

下面是修改后的完整宏代码，可自动扫描指定文件夹，筛选出修改日期为当日或**文件名包含当日日期（格式YYYYMMDD）**的CSV文件并附加到邮件发送：

Sub Send_CollectionsEmail_with_Attachment()
    Dim OutlookApp As Object
    Dim OutlookNamespace As Object
    Dim MyMail As Object
    Dim AttachedFolder As String
    Dim TodayDateStr As String
    Dim FileName As String
    Dim FullFilePath As String
    
    ' 设置要扫描的文件夹完整路径，请替换为你的实际路径
    AttachedFolder = "C:\DQ BUSINESS LOANS\"
    ' 生成当日日期的YYYYMMDD格式字符串
    TodayDateStr = Format(Date, "YYYYMMDD")
    
    Set OutlookApp = Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    Set MyMail = OutlookApp.CreateItem(olMailItem)
    
    With MyMail
        .To = "open@abc.org"
        .CC = "mcl@abc.org"
        .Subject = "DQ_Business_Loans_Daily"
        .Body = "Please see the attached report."
    End With
    
    ' 遍历文件夹内所有CSV文件
    FileName = Dir(AttachedFolder & "*.csv")
    Do While FileName <> ""
        FullFilePath = AttachedFolder & FileName
        ' 判断条件：修改日期为当日 或 文件名包含当日日期串
        If DateValue(FileDateTime(FullFilePath)) = Date Or InStr(FileName, TodayDateStr) > 0 Then
            MyMail.Attachments.Add FullFilePath
            ' 如果只需要添加第一个符合条件的文件，可取消下面一行注释
            ' Exit Do
        End If
        FileName = Dir
    Loop
    
    ' 只有找到附件时才发送邮件
    If MyMail.Attachments.Count > 0 Then
        MyMail.Send
    Else
        MsgBox "未找到符合条件的CSV文件，请检查文件夹或日期设置。"
    End If
    
    ' 清理对象
    Set MyMail = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing
End Sub

关键修改说明： #

• 文件夹路径：请将AttachedFolder的值替换为你的CSV文件所在的完整文件夹路径，注意末尾加上反斜杠\
• 日期格式化：用Format(Date, "YYYYMMDD")生成统一的日期字符串，匹配文件名中的日期格式
• 文件筛选逻辑：
  • DateValue(FileDateTime(FullFilePath)) = Date：提取文件修改日期的日期部分，与当日日期对比
  • InStr(FileName, TodayDateStr) > 0：检查文件名中是否包含当日日期串
• 邮件发送判断：增加了附件数量检查，避免无附件时发送空邮件
• 可选设置：如果只需要添加第一个符合条件的文件，取消Exit Do的注释即可

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