VBA循环通过电子邮件附件并根据给定的标准进行保存

这是上一个问题的后续（ VBA从具有多个帐户的电子邮件保存附件（基于定义的标准） ）

场景：我有一个代码，在特定的Outlook帐户中循环遍历所有电子邮件，并将附件保存到选定的文件夹。 以前，我的问题是select哪个文件夹（和帐户）从哪里提取附件（这是解决与上一个问题的build议）。

问题1：该代码在该行显示“types不匹配”错误：

Set olMailItem = olFolder.Items(i) 

问题2：如问题标题中所述，我的主要目标是遍历所有附件并仅保存那些具有给定条件的文件（excel文件，其中一个工作表名称为“ASK”，另一个名为“BID”）。 不只是一个简单的如果考虑到这些标准，我必须下载所有文件到“临时文件夹”，select并把最终的结果文件放在输出文件夹中，或者将所有文件下载到最终文件夹中，不符合标准。

问题：我似乎无法find做这两种操作的方法。

问：如何做到这一点？ 那两个会更有效率呢？

码：

 Sub email() Application.ScreenUpdating = False Dim olApp As New Outlook.Application Dim olNameSpace As Object Dim olMailItem As Outlook.MailItem Dim olFolder As Object Dim olFolderName As String Dim olAtt As Outlook.Attachments Dim strName As String Dim sPath As String Dim i As Long Dim j As Integer Dim olSubject As String Dim olSender As String Dim sh As Worksheet Dim LastRow As Integer 'delete content except from row 1 ThisWorkbook.Worksheets("FileNames").Rows(2 & ":" & ThisWorkbook.Worksheets("FileNames").Rows.count).Delete 'set foldername and subject olFolderName = ThisWorkbook.Worksheets("Control").Range("D10") 'olSubject = ThisWorkbook.Worksheets("Control").Range("D16") olSender = ThisWorkbook.Worksheets("Control").Range("D16") sPath = Application.FileDialog(msoFileDialogFolderPicker).Show sPathstr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) Set olNameSpace = olApp.GetNamespace("MAPI") 'check if folder is subfolder or not and choose olFolder accordingly 'Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders(olFolderName) Set olFolder = olNameSpace.Folders("[e-mail]").Folders("Inbox") If (olFolder = "") Then Set olFolder = olNameSpace.Folders("[e-mail]").Folders("Inbox") End If 'loop through mails h = 2 For i = 1 To olFolder.Items.count Set olMailItem = olFolder.Items(i) 'check if the search name is in the email subject 'If (InStr(1, olMailItem.Subject, olSubject, vbTextCompare) <> 0) Then If (InStr(1, olMailItem.Sender, olSender, vbTextCompare) <> 0) Then With olMailItem strName = .Attachments.Item(j).DisplayName 'check if file already exists If Not Dir(sPathstr & "\" & strName) = "" Then .Attachments(j).SaveAsFile sPathstr & "\" & "(1)" & strName ThisWorkbook.Worksheets("FileNames").Range("A" & h) = "(1)" & strName Else .Attachments(j).SaveAsFile sPathstr & "\" & strName ThisWorkbook.Worksheets("FileNames").Range("A" & h) = strName End If h = h + 1 Next End With End If Next Application.ScreenUpdating = True MsgBox "Download complete!", vbInformation + vbOKOnly, "Done" End Sub 

Answer 1

问题1：

您可能会遇到邀请或您的文件夹中的普通邮件以外的东西。
检查Item的Class属性以查看它是否是olMail

问题2：

我会去处理错误，在这里：

1. 用适当的名称保存在临时文件夹中
2. 打开文件
3. 试着去床单
4. 如果出现错误，请closures文件
5. 如果没有错误，请将文件保存到目标文件夹中

完整代码：

 Sub email_DGMS89() Application.ScreenUpdating = False Dim olApp As New Outlook.Application Dim olNameSpace As Object Dim olMailItem As Outlook.MailItem Dim olFolder As Object Dim olFolderName As String Dim olAtt As Outlook.Attachments Dim strName As String Dim sPath As String Dim i As Long Dim j As Integer Dim olSubject As String Dim olSender As String Dim sh As Worksheet Dim LastRow As Integer Dim TempFolder As String: TempFolder = VBA.Environ$("TEMP") Dim wB As Excel.Workbook 'delete content except from row 1 ThisWorkbook.Worksheets("FileNames").Rows(2 & ":" & ThisWorkbook.Worksheets("FileNames").Rows.Count).Delete 'set foldername and subject olFolderName = ThisWorkbook.Worksheets("Control").Range("D10") 'olSubject = ThisWorkbook.Worksheets("Control").Range("D16") olSender = ThisWorkbook.Worksheets("Control").Range("D16") sPath = Application.FileDialog(msoFileDialogFolderPicker).Show sPathstr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) Set olNameSpace = olApp.GetNamespace("MAPI") 'check if folder is subfolder or not and choose olFolder accordingly 'Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders(olFolderName) Set olFolder = olNameSpace.Folders("[e-mail]").Folders("Inbox") If (olFolder = "") Then Set olFolder = olNameSpace.Folders("[e-mail]").Folders("Inbox") End If 'loop through mails h = 2 For i = 1 To olFolder.items.Count '''Const olMail = 43 (&H2B) If olFolder.items(i).Class <> olMail Then Else Set olMailItem = olFolder.items(i) 'check if the search name is in the email subject 'If (InStr(1, olMailItem.Subject, olSubject, vbTextCompare) <> 0) Then If (InStr(1, olMailItem.Sender, olSender, vbTextCompare) <> 0) Then With olMailItem For j = 1 To .Attachments.Count strName = .Attachments.Item(j).DisplayName 'check if file already exists If Not Dir(sPathstr & "\" & strName) = vbNullString Then strName = "(1)" & strName Else End If '''Save in temp .Attachments(j).SaveAsFile TempFolder & "\" & strName ThisWorkbook.Worksheets("FileNames").Range("A" & h) = strName '''Open file as read only Set wB = workbooks.Open(TempFolder & "\" & strName, True) DoEvents '''Start error handling On Error Resume Next Set sh = wB.sheets("ASK") Set sh = wB.sheets("BID") If Err.Number <> 0 Then '''Error = At least one sheet is not detected Else '''No error = both sheets found .Attachments(j).SaveAsFile sPathstr & "\" & strName End If Err.Clear Set sh = Nothing wB.Close On Error GoTo 0 h = h + 1 Next j End With End If End If Next i Application.ScreenUpdating = True MsgBox "Download complete!", vbInformation + vbOKOnly, "Done" End Sub