如何导入Outlook中文件名动态变化的Excel附件？

问题描述 #

我是VBA新手，编写从Outlook导入Excel文件的代码时遇到问题。每日目标附件文件名会动态变化，例如周一为"FileABC_12345.xls"、周二为"FileABC_52359.xls"等。我尝试用通配符匹配文件名，但代码无法正常运行，以下是我的代码：

Sub ExtractDataFromOutlookEmail()
    
    Dim OutlookApp As Outlook.Application
    Dim OutlookNamespace As Outlook.Namespace
    Dim OutlookFolder As Outlook.Folder
    Dim CurrentOutlookFilter As Outlook.MailItem
    Dim OutlookItem As Outlook.MailItem
    Dim ExcelApp As Excel.Application
    Dim ExcelWorkbook As Excel.Workbook
    Dim ExcelWorksheet As Excel.Worksheet
    Dim Attachment As Outlook.Attachment
    Dim TempFilePath As String
    Dim RangeToExtract As Excel.Range
    Dim OutlookFilter As Outlook.View
    Dim InboxItems As Outlook.Items
    Dim ResultItems As Outlook.Items
    Dim i As Integer
    Dim iFilterItem As Integer
    Dim sFileDate As String
    
    
    On Error GoTo Errorhandler
    
    Range("M3") = "No File Yet"
    Range("M4") = "No File Yet"
    
    TempFilePath = Environ$("temp") & "\"
    
    Set RangeToExtract = ThisWorkbook.Sheets("Summary").Range("A1")
    
    On Error Resume Next
    Set OutlookApp = GetObject(, "Outlook.Application")
    
    On Error GoTo 0
    If OutlookApp Is Nothing Then
    
        Set OutlookApp = CreateObject("Outlook.Application")
        
    End If
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    Set OutlookFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox) ' Change to the appropriate folder
    Set InboxItems = OutlookFolder.Items
    Set ResultItems = InboxItems.Restrict("@SQL=(urn:schemas:httpmail:subject Like '%SubjectofEmail%') AND (urn:schemas:httpmail:hasattachment=true) AND %yesterday(urn:schemas:httpmail:datereceived)%")
    For iFilterItem = 1 To ResultItems.Count
        
        ' Check if the email has the desired attachments
        Set OutlookItem = ResultItems(iFilterItem)
        If OutlookItem.Attachments.Count >= 1 Then
            
            Dim AttachmentTitles(1 To 3) As String
            
            AttachmentTitles(1) = "FileABC_" & "*" & ".xls"  'THIS IS THE PROBLEM LINE!!!!!!!!
            
            AttachmentTitles(2) = "ignore123.xlsx" 'ignore, there is no 2nd attachement
            
            AttachmentTitles(3) = "ignore123.xlsx" 'ignore, there is no 3rd attachement
            
            Dim AttachmentCount As Integer
            
            AttachmentCount = 0
            
            ' Loop through the attachments in the email
            
            For Each Attachment In OutlookItem.Attachments
                
                For i = 1 To 3
                    
                    If Attachment.Filename = AttachmentTitles(i) Then
                    
                        
                        ' Save the attachment to the temporary location
                        
                        Attachment.SaveAsFile TempFilePath & AttachmentTitles(i)
                        
                        ' Create a new Excel application
                        
                        Set ExcelApp = CreateObject("Excel.Application")
                        
                        ExcelApp.Visible = False
                        
                        ' Open the saved Excel attachment
                        
                        Set ExcelWorkbook = ExcelApp.Workbooks.Open(TempFilePath & AttachmentTitles(i), , , , "123456")
                        
                        ' Copy the data from the Excel attachment
                        
                        Set ExcelWorksheet = ExcelWorkbook.Sheets(1) ' Assuming data is in the first sheet
                        
                        'Add up the column Qs where column T = N and put in cell K3 also print out the datestamp
                        Range("M3") = ExcelWorksheet.Range("C55").Value
                        Range("M4") = Format(sFileDate, "dd/mm/yyyy")
                        
                        'ExcelWorksheet.UsedRange.Copy Destination:=RangeToExtract.Offset(, AttachmentCount * 3) ' Offset to paste data in different columns
                        
                        ' Close the Excel attachment
                        
                        ExcelWorkbook.Close SaveChanges:=False
                        
                        
                        ExcelApp.Quit
                        
                        ' Clean up Excel objects
                        
                        Set ExcelWorksheet = Nothing
                        
                        Set ExcelWorkbook = Nothing
                        
                        Set ExcelApp = Nothing
                        
                        ' Increment the attachment count
                        
                        AttachmentCount = AttachmentCount + 1
                        
                        ' Exit the loop if all three attachments are processed
                        
                        If AttachmentCount >= 3 Then Exit For
                        
                    End If
                    
                Next i
                
            Next Attachment
            
            ' Exit the loop after processing the email
            
            Exit For
            
        End If
        
    Next iFilterItem
    

    
    Set OutlookItem = Nothing
    
    Set OutlookFolder = Nothing
    
    Set OutlookNamespace = Nothing
    
    Set OutlookApp = Nothing
    
    ' Delete the temporary Excel files
    
    For i = 1 To 3
        
        If Dir(TempFilePath & AttachmentTitles(i)) <> "" Then
            On Error Resume Next
            Kill TempFilePath & AttachmentTitles(i)
            On Error GoTo Errorhandler
        End If
        
    Next i
    

finally:
    On Error Resume Next
    'General cleanup
    Exit Sub
    Resume
Errorhandler:
    'On Error Resume Next
    MsgBox Err.Number & " - " & Err.Description
    GoTo finally
    
End Sub

问题根源及修复方案 #

1. 通配符匹配逻辑错误：VBA中=运算符不支持通配符匹配，必须用Like关键字判断文件名是否符合指定模式。
2. 附件保存文件名错误：不能用带通配符的字符串作为保存文件名，应该直接使用附件的真实文件名Attachment.Filename。
3. 未赋值变量：sFileDate变量未赋值，导致M4单元格显示异常，可改用邮件接收时间或文件内的日期值。

修复后的完整代码 #

Sub ExtractDataFromOutlookEmail()
    
    Dim OutlookApp As Outlook.Application
    Dim OutlookNamespace As Outlook.Namespace
    Dim OutlookFolder As Outlook.Folder
    Dim OutlookItem As Outlook.MailItem
    Dim ExcelApp As Excel.Application
    Dim ExcelWorkbook As Excel.Workbook
    Dim ExcelWorksheet As Excel.Worksheet
    Dim Attachment As Outlook.Attachment
    Dim TempFilePath As String
    Dim RangeToExtract As Excel.Range
    Dim InboxItems As Outlook.Items
    Dim ResultItems As Outlook.Items
    Dim iFilterItem As Integer
    Dim sFileDate As String
    
    On Error GoTo Errorhandler
    
    Range("M3") = "No File Yet"
    Range("M4") = "No File Yet"
    
    TempFilePath = Environ$("temp") & "\"
    
    Set RangeToExtract = ThisWorkbook.Sheets("Summary").Range("A1")
    
    On Error Resume Next
    Set OutlookApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    If OutlookApp Is Nothing Then
        Set OutlookApp = CreateObject("Outlook.Application")
    End If
    
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    Set OutlookFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox) ' 可修改为目标文件夹
    Set InboxItems = OutlookFolder.Items
    ' 筛选符合条件的邮件：主题包含指定内容、有附件、昨天接收
    Set ResultItems = InboxItems.Restrict("@SQL=(urn:schemas:httpmail:subject Like '%SubjectofEmail%') AND (urn:schemas:httpmail:hasattachment=true) AND %yesterday(urn:schemas:httpmail:datereceived)%")
    
    For iFilterItem = 1 To ResultItems.Count
        Set OutlookItem = ResultItems(iFilterItem)
        
        If OutlookItem.Attachments.Count >= 1 Then
            Dim AttachmentPattern As String
            AttachmentPattern = "FileABC_*.xls" ' 定义文件名匹配模式
            Dim AttachmentCount As Integer
            AttachmentCount = 0
            
            ' 遍历邮件附件
            For Each Attachment In OutlookItem.Attachments
                ' 使用Like判断文件名是否匹配模式
                If Attachment.Filename Like AttachmentPattern Then
                    ' 用附件真实文件名保存到临时路径
                    Attachment.SaveAsFile TempFilePath & Attachment.Filename
                    
                    ' 启动Excel应用
                    Set ExcelApp = CreateObject("Excel.Application")
                    ExcelApp.Visible = False
                    
                    ' 打开保存的附件
                    Set ExcelWorkbook = ExcelApp.Workbooks.Open(TempFilePath & Attachment.Filename, , , , "123456")
                    Set ExcelWorksheet = ExcelWorkbook.Sheets(1) ' 假设数据在第一个工作表
                    
                    ' 提取数据到指定单元格
                    Range("M3") = ExcelWorksheet.Range("C55").Value
                    ' 使用邮件接收时间作为日期戳，也可改用文件内的日期
                    sFileDate = OutlookItem.ReceivedTime
                    Range("M4") = Format(sFileDate, "dd/mm/yyyy")
                    
                    ' 关闭文件并退出Excel
                    ExcelWorkbook.Close SaveChanges:=False
                    ExcelApp.Quit
                    
                    ' 清理Excel对象
                    Set ExcelWorksheet = Nothing
                    Set ExcelWorkbook = Nothing
                    Set ExcelApp = Nothing
                    
                    AttachmentCount = AttachmentCount + 1
                    Exit For ' 找到目标附件后退出循环
                End If
            Next Attachment
            
            Exit For ' 处理完符合条件的邮件后退出循环
        End If
    Next iFilterItem
    
    ' 清理Outlook对象
    Set OutlookItem = Nothing
    Set OutlookFolder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing
    
    ' 删除临时文件（如果存在）
    For Each Attachment In OutlookItem.Attachments
        If Attachment.Filename Like "FileABC_*.xls" Then
            If Dir(TempFilePath & Attachment.Filename) <> "" Then
                On Error Resume Next
                Kill TempFilePath & Attachment.Filename
                On Error GoTo Errorhandler
            End If
        End If
    Next

finally:
    On Error Resume Next
    Exit Sub
Errorhandler:
    MsgBox Err.Number & " - " & Err.Description
    GoTo finally
    
End Sub

额外说明 #

• 代码中%SubjectofEmail%需替换为实际邮件主题包含的关键词
• 若需要处理多个符合条件的邮件，可移除对应位置的Exit For语句
• 临时文件删除逻辑做了调整，确保删除的是实际保存的文件

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