CODEWITHSUNDEEP
excelvbaoutlookattachment
Daniel Barker
Daniel Barker

Reputation: 1

Save Excel attachments from incoming emails with certain text in the subject

I had been using Outlook rules to run a script if the subject contains "My Calls" to save an Excel file.

Since an update I can no longer use the "run a script" option of Outlook's rules. I haven't managed to work out the VBA to check all emails for My Calls in the subject to then run the script.

Private Sub SaveAttachments(Item As Outlook.MailItem)

If Item.Attachments.Count > 0 Then

    Dim EmAttach As Outlook.Attachments 
    Dim AttachCount As Long 
    Dim EmAttFile As String 
    Dim sFileType As String 
    Dim i As Long

    Set EmAttach = Item.Attachments AttachCount = EmAttach.Count

    For i = AttachCount To 1 Step -1

       'Get the file name. 
        EmAttFile = EmAttach.Item(i).FileName

        If LCase(Right(EmAttFile, 5)) = ".xlsx" Then

            'Get the path to your My Documents folder 
            DestFolderPath = CreateObject("WScript.Shell").SpecialFolders(16) DestFolderPath = DestFolderPath & "\Attachments"

            'Combine with the path to the folder. 
            EmAttFile = DestFolderPath & EmAttFile

            'Save the attachment as a file. 
             EmAttach.Item(i).SaveAsFile EmAttFile 
         End If 
     Next i 
End If

End Sub

I need this code to work automatically. I receive 35+ spreadsheets with a list of calls that an agent has completed. These have to be saved in a fixed location (they don't have access to) so another sheet can extract the data into a dashboard.

Upvotes: 0

Views: 665

Answers (1)

Tragamor
Tragamor

Reputation: 3634

So I recently wanted to automate some pdf attachments saves along similar lines to what you want to achieve. The way I set it up was to have a subfolder that I could apply a filter rule to incoming e-mails to segregate the e-mails I want to pull the pdf's from into this folder. With VBA you can pickup the new e-mails and process the attachments.

The following code is what I currently use so would need to be adapted for use, but shows the general approach

Within the 'ThisOutlookSession' module

Private WithEvents ReportItems As Outlook.Items

Private Sub Application_Startup()
    On Error Resume Next
    With Outlook.Application
        Set ReportItems = .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("PDFData").Items
    End With
End Sub

Private Sub ReportItems_ItemAdd(ByVal Item As Object)
    On Error Resume Next
    If TypeName(Item) = "MailItem" Then Call SavePDFAttachmentReports(Item, "C:\Reports")
End Sub

Within a module

Sub SavePDFAttachmentReports(ByVal Item As Object, FilePath As String)
    Dim i As Long, FileName As String
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
    
    With Item.Attachments
        If .Count > 0 Then
            For i = 1 To .Count
                FileName = FilePath & .Item(i).FileName
                If LCase(Right(FileName, 3)) = "pdf" Then
                    FileName = Left(FileName, Len(FileName) - 4) & " Reverse Phase Report.pdf"
                    .Item(i).SaveAsFile FileName
                End If
            Next i
        End If
    End With
End Sub

Adapted (untested):

Private WithEvents ReportItems As Outlook.Items

Private Sub Application_Startup()
    On Error Resume Next
    With Outlook.Application
        Set ReportItems = .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Excel Reports").Items
    End With
End Sub

Private Sub ReportItems_ItemAdd(ByVal Item As Object)
    On Error Resume Next
    If TypeName(Item) = "MailItem" Then Call _
        SaveXLSXAttachments(Item, Environ("USERPROFILE") & "\My Documents\Attachments")
End Sub

Sub SaveXLSXAttachments(ByVal Item As Object, FilePath As String)
    Dim i As Long, FileName As String
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"

    With Item.Attachments
        If .Count > 0 Then
            For i = 1 To .Count
                FileName = FilePath & .Item(i).FileName
                'Debug.Print FileName
                If LCase(Right(FileName, 5)) = ".xlsx" Then .Item(i).SaveAsFile FileName
            Next i
        End If
    End With
End Sub

Upvotes: 1

Related Questions