VBA遍历电子邮件附件并根据给定条件进行保存 [英] VBA to loop through email attachments and save based on given criteria

问题描述

这是上一个问题( 方案::我有一个代码循环浏览某个Outlook帐户中的所有电子邮件，并将附件保存到选定的文件夹中.以前，我的问题是从哪里选择要提取附件的文件夹(和帐户)(通过上一个问题的建议解决了这个问题.)

Scenario: I have a code that loops through all e-mails in a certain outlook account, and saves the attachments to a selected folder. Previously, my problem was selecting which folder (and account) from where to extract the attachments (this was solved with a suggestion from the previous question).

问题1:该代码在以下行显示类型不匹配"错误:

Issue 1: The code is presenting a "Type Mismatch" error at the line:

Set olMailItem = olFolder.Items(i)

问题2:如问题标题所述，我的主要目标是循环浏览所有附件，并仅保存具有给定条件的附件(excel文件，一个工作表名称为"ASK"和一个名为"BID"的广告).如果要考虑这些条件，我将不得不要么将所有文件下载到临时文件夹"，然后将所有最终文件下载到输出文件夹中，要么将所有文件下载到最终文件夹中，然后删除这些文件.不符合条件.

Issue 2: As stated in the question title, my main objective is to loop through all the attachments and save only those that have a given criteria (excel file, with one sheet name "ASK" and one named "BID"). More than a simple If to account for these criteria, I have to either download all files to "temp folder", to the selection and put the final resulting files in the output folder, or download everything to the final folder and delete the files that do not meet the criteria.

问题:我似乎找不到执行其中任何一项操作的方法.

Problem: I can't seem to find the way to do either of those operations.

问题:一个人怎么做?而这两个中哪个更有效?

Question: How would one do that? And which of those two would be more efficient?

代码:

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

推荐答案

问题1:

您的文件夹中可能有这样的会议邀请或常规邮件以外的其他内容.
检查Item的Class属性以查看它是否为olMail

Issue 1 :

You probably have so meeting invites or something other than a regular mail in your folder.
Check the Class property of the Item to see if it's olMail

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

I'll go with error handling, here :

1. 使用适当的名称保存在temp文件夹中
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("[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

这篇关于VBA遍历电子邮件附件并根据给定条件进行保存的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！