Dwonload attachment from specific sender and open in excel

Question

I am rather new to VBA and was hoping to get some help on a project. To give you some background, I get an email in outlook about every 15 minutes with an excel attachment. I need to open the attachment once the email gets in and view it / compare it to the email that was sent 15 minutes prior. If there is a difference in the emails then I must preform an action. I was hoping to automate at least some of this process. Ideally, I could use a macro to scan my inbox for any new message from a particular sender. If it finds a message it could then check for an attachment and if the attachment is there it would download and open it.

In an ideal world the other thing I could do is compare the prior excel attachment to the current one and ping a message (alert) if it is different.

Any help would be much appreciated. As I said, I am new to VBA but I am trying my best to understand functions.

Answer 1

This should get you started. Assuming you have selected the e-mail in outlook:

Sub check_for_changes()
    'Created by Fredrik Östman www.scoc.se
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Set myOlExp = myOlApp.Explorers.Item(1)
    Set myOlSel = myOlExp.Selection
    Set mymail = myOlSel.Item(1)
    Dim myAttachments As Outlook.Attachments
    Set myAttachments = mymail.Attachments
    Dim Atmt As Attachment
    Set Atmt = myAttachments(1)

    new_file_name = "C:\tmp\new_received_file.xlsx"
    old_file_name = "C:\tmp\old_received_file.xlsx"

    FileCopy new_file_name, old_file_name

    Atmt.SaveAsFile new_file_name

    Dim eApp As Object
    Set eApp = CreateObject("Excel.Application")

    eApp.Application.Visible = True

    Dim new_file As Object
    eApp.workbooks.Open new_file_name
    Set new_file = eApp.ActiveWorkbook

    Dim old_file As Object
    eApp.workbooks.Open old_file_name
    Set old_file = eApp.ActiveWorkbook

    'Find range to compare
    start_row = old_file.sheets(1).usedrange.Row
    If new_file.sheets(1).usedrange.Row > start_row Then start_row = new_file.sheets(1).usedrange.Row

    end_row = old_file.sheets(1).usedrange.Row + old_file.sheets(1).usedrange.Rows.Count
    If new_file.sheets(1).usedrange.Rows.Count + new_file.sheets(1).usedrange.Row > end_row Then end_row = new_file.sheets(1).usedrange.Rows.Count + new_file.sheets(1).usedrange.Row

    start_col = old_file.sheets(1).usedrange.Column
    If new_file.sheets(1).usedrange.Column > start_col Then start_col = new_file.sheets(1).usedrange.Column

    end_col = old_file.sheets(1).usedrange.Column + old_file.sheets(1).usedrange.Columns.Count
    If new_file.sheets(1).usedrange.Columns.Count + new_file.sheets(1).usedrange.Column > end_row Then end_row = new_file.sheets(1).usedrange.Columns.Count + new_file.sheets(1).usedrange.Column

    'Check all cells
    something_changed = False
    For i = start_row To end_row
        For j = start_col To end_col
            If new_file.sheets(1).Cells(i, j) <> old_file.sheets(1).Cells(i, j) Then
                new_file.sheets(1).Cells(i, j).Interior.ColorIndex = 3 'Mark red
                something_changed = True
            End If
        Next j
    Next i

    If something_changed Then
        new_file.Activate
    Else
        new_file.Close
        old_file.Close
        If eApp.workbooks.Count = 0 Then eApp.Quit
        MsgBox "No changes"
    End If

End Sub

Answer 2

Interesting question, I'll get you started with the outlook part. You'll probably want to split the question between Outlook and Excel.

Here is some code I use to save every attachment I have been sent in Outlook to save space.

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim pobjMsg As Outlook.MailItem 'Object
Dim objSelection As Outlook.Selection

On Error Resume Next

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

For Each pobjMsg In objSelection
    SaveAttachments_Parameter pobjMsg
Next

ExitSub:
Set pobjMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
MsgBox "Export Complete"
End Sub
Public Sub SaveAttachments_Parameter(objMsg As MailItem)
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

' Get the path to your My Documents folder
strFolderpath = "C:\Users\******\Documents\Reports\"
'On Error Resume Next
' Set the Attachment folder.
strFolderpath = strFolderpath & "Outlook Attachments\"
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count

If lngCount > 0 Then
' We need to use a count down loop for removing items' from a collection. Otherwise, the loop counter gets' confused and only every other item is removed.
    For i = lngCount To 1 Step -1
        ' Save attachment before deleting from item.
        ' Get the file name.
        strFile = objAttachments.Item(i).FileName
        If Right(strFile, 4) = ".png" Or Right(strFile, 4) = ".jpg" Or Right(strFile, 4) = ".gif" Then
        GoTo cont
        End If
        ' Combine with the path to the Temp folder.
        strFile = strFolderpath & objMsg.SenderName & "." & Format(objMsg.ReceivedTime, "yyyy-MM-dd h-mm-ss") & "." & strFile
        ' Save the attachment as a file.
        objAttachments.Item(i).SaveAsFile strFile

        ' Delete the attachment - You might not want this part
        'objAttachments.Item(i).Delete

        'write the save as path to a string to add to the message
        'check for html and use html tags in link
        If objMsg.BodyFormat = olFormatHTML Then
            strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & Replace(strFile, " ", "%20") & ">"
        Else
            strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & Replace(strFile, " ", "%20") & ">"
        End If
cont:
    Next i

    ' Adds the filename string to the message body and save it
    ' Check for HTML body
    If objMsg.BodyFormat = olFormatHTML Then
        objMsg.Body = "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
    Else
        objMsg.HTMLBody = "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.HTMLBody
    End If

    objMsg.Save
End If


ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objOL = Nothing
End Sub

The part in the code which says

    If Right(strFile, 4) = ".png" Or Right(strFile, 4) = ".jpg" Or Right(strFile, 4) = ".gif" Then
    GoTo cont

you could change to something like:

    If objMsg.SenderName = "John Smith" Then
    GoTo cont

that way it will only save the attachment from that specific sender.

Then, once you have two or more files, you can load the files using another macro in excel and compare the two files, then send you an email if there are any discrepancies.

Hope that gets you started.