excel - VBA循环遍历电子邮件附件并根据给定条件保存

Question

这是上一个问题 ( VBA to save attachments (based on defined criteria) from an email with multiple accounts ) 的后续问题

场景:我有一个代码可以循环遍历某个 Outlook 帐户中的所有电子邮件，并将附件保存到选定的文件夹中。以前，我的问题是选择从哪个文件夹(和帐户)提取附件(这是通过上一个问题的建议解决的)。

问题 1:代码在以下行出现“类型不匹配”错误:

Set olMailItem = olFolder.Items(i)

问题 2:如问题标题所述，我的主要目标是循环遍历所有附件并仅保存具有给定条件的附件(Excel 文件，其中一个工作表名称为“ASK”)和一个名为“BID”的)。不仅仅是一个简单的“如果”要考虑这些标准，我必须将所有文件下载到“临时文件夹”，选择并将最终结果文件放入输出文件夹中，或者将所有内容下载到最终文件夹并删除那些文件不符合标准。

问题:我似乎找不到执行这些操作的方法。

问题:如何做到这一点？这两者中哪一个效率更高？

代码:

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("email@email.com").Folders("Inbox")

If (olFolder = "") Then
    Set olFolder = olNameSpace.Folders("email@email.com").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:

您的文件夹中可能有 session 邀请或普通邮件以外的其他内容。
检查 Item 的 Class 属性，看看它是否是 olMail

问题 2:

我将在这里进行错误处理:

1. 使用适当的名称保存在临时文件夹中
2. 打开文件
3. 尝试去床单
4. 如果出现错误，只需关闭文件
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("email@email.com").Folders("Inbox")

If (olFolder = "") Then
    Set olFolder = olNameSpace.Folders("email@email.com").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