Clever Geek Handbook

VBA to cycle through email attachments and save according to specified criteria

This is the result of a previous question ( VBA to save attachments (based on certain criteria) from email with multiple accounts )

Scenario: I have some code that processes all emails in a specific Outlook account and saves attachments to a selected folder. Previously, my problem was to choose which folder (and account) to fetch attachments (this was solved with the suggestion from the previous question).

Problem 1: . The code presents the "Type mismatch error" error at the line:

Set olMailItem = olFolder.Items(i)

Problem 2: As stated in the title of the question, my main goal is to skip all attachments and keep only those that have the given criteria (excel file, with one sheet name "ASK" and one called "BID"). More than just. Given these criteria, I have to either upload all files to a "temp folder" and select the final output files in the output folder, or upload everything to the destination folder and delete files that do not match the criteria.

Problem: I cannot find a way to accomplish any of these operations.

Question: How to do it? And which of the two would be more effective?

Code:

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
+3


source to share


1 answer


Problem 1:

You probably have meeting requests or something other than regular mail in your folder.
Check the property Class

Item

to see if it isolMail

Problem 2:

I'll go with error handling, here:



  • Save in temp folder with appropriate name
  • Open the file
  • Try to get to the sheets
  • If there is an error, just close the file
  • If there is no error, save the file in the destination folder

Complete code:

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
+2


source






More articles:


All Articles