locked
In Outlook, how can I use VBA to search through .xls attachments in my Inbox for specific values contained in a closed workbook? RRS feed

  • Question

  • Real world background

    Each morning I get an automatic email from a noreply address that contains an .xls attachment.  This file is a report that lists all the products currently in our RMA facility.  The details include model number, serial number, receiving date, repair status, etc., for over a thousand products.  Sometimes we're on the lookout for a particular model or serial number, but we never quite know when it will arrive because that depends on people all over the country mailing things to us.

    If I want to manually accomplish what I'd like to do, I'll open the latest report in Excel and do a search for the model number or serial number, or perhaps I'll filter it if I'm looking for a few different things.

    Goal

    I'd like to automate this by manually keeping a spreadsheet with a current list of models/serials/whatever that I'm looking for and have a custom menu item in Outlook that runs a macro whenever I click it so that, in the background, the VBA code checks each item in my lookout list against the most current report. The cherry on top would be for this macro to send me a notification email that contained the lookout list item that was found along with the rest of the fields from its line in the report.

    Noob Theory

    I'm not sure if using an Outlook rule would be useful to get the automated reports into a subfolder, first. I've found a good tutorial on how to save attachments, so if that needed to be done, it's no problem.  I have dabbled with the INDIRECT.ext function that lets you get into closed workbooks, but I'm not sure if that's going to come into play, here.  It seems totally plausible that all this can go on in the background, the end result being a message box that says, "No lookout items found," or "Three items found. Details will be emailed to you shortly."  The emails, themselves, would ideally include only the product details pertinent to me such as the case number, model number, serial number, receive date, and status.

    We just got Outlook after being stuck in Lotus Notes forever, and it's kind of blowing my mind that this stuff is even possible.  Thanks in advance for sharing your expertise.

    Friday, August 16, 2013 4:37 AM

Answers

  • What you describe certainly seems feasible and it should be possible to run the script from a rule that would save the xls file attached to an identifiable incoming message, to a temporary location. It would then look through the add-in for the data you want to locate and then if present warn you by a pop up message or by sending you an e-mail, or whatever.

    The basic code could be something like the following. Run the script CheckAttachments from the rule. (I have included a Test macro so that you can test with a message you have already received).

    Change the values in bold to reflect where you wish to save the attachments and the value you are looking for in Column A of the worksheet. If the value is in some other column you will need to modify the FindValue function to reflect the column in question.

    The macro saves the attachment to a temporary file, examines it to see if it contains the value you seek and if it does it pops up a message. If it is not present the file is delete from the folder (not from the message).

    The macro looks for only one value, but if you wish to look for several values then you could assemble them in an array and loop through them.

    Option Explicit

    Sub CheckAttachments(olItem As MailItem)
    Const strPath As String = "C:\Path\" 'The path to save the workbook
    Const strFindText as String = "The value you want to find"
    Dim strFilename As String
    Dim olAttach As Attachment
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim bXStarted As Boolean
    Dim bFound As Boolean
        If olItem.Attachments.Count > 0 Then
            For Each olAttach In olItem.Attachments
                If Right(LCase(olAttach.Filename), 3) = "xls" Then
                    strFilename = strPath & Format(olItem.ReceivedTime, "yyyymmdd-HHMMSS") & _
                                  Chr(32) & olAttach.Filename
                    olAttach.SaveAsFile strFilename
                    On Error Resume Next
                    Set xlApp = GetObject(, "Excel.Application")
                    If Err <> 0 Then
                        Application.StatusBar = "Please wait while Excel source is opened ... "
                        Set xlApp = CreateObject("Excel.Application")
                        bXStarted = True
                    End If
                    On Error GoTo 0
                    'Open the workbook to read the data
                    Set xlWB = xlApp.Workbooks.Open(strFilename)
                    Set xlSheet = xlWB.Sheets("Sheet1")

                    If FindValue(strFindText, xlSheet) Then
                        MsgBox "Value found in " & strFilename
                        bFound = True
                    End If
                    xlWB.Close 0
                    If bXStarted Then xlApp.Quit
                    If Not bFound Then Kill strFilename
                    Exit For
                End If
            Next olAttach
        End If
    End Sub

    Function FindValue(FindString As String, iSheet As Object) As Boolean
    Dim Rng As Object
        If Trim(FindString) <> "" Then
            With iSheet.Range("A:A")
                Set Rng = .Find(What:=FindString, _
                                After:=.Cells(.Cells.Count), _
                                LookIn:=-4163, _
                                LookAt:=1, _
                                SearchOrder:=1, _
                                SearchDirection:=1, _
                                MatchCase:=False)
                If Not Rng Is Nothing Then
                    FindValue = True
                Else
                    FindValue = False
                End If
            End With
        End If
    End Function

    Sub Test()
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    CheckAttachments olMsg
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com


    • Edited by Graham MayorMVP Saturday, August 17, 2013 2:09 PM
    • Marked as answer by Shane Ry Monday, August 19, 2013 3:07 AM
    Saturday, August 17, 2013 2:08 PM

All replies

  • What you describe certainly seems feasible and it should be possible to run the script from a rule that would save the xls file attached to an identifiable incoming message, to a temporary location. It would then look through the add-in for the data you want to locate and then if present warn you by a pop up message or by sending you an e-mail, or whatever.

    The basic code could be something like the following. Run the script CheckAttachments from the rule. (I have included a Test macro so that you can test with a message you have already received).

    Change the values in bold to reflect where you wish to save the attachments and the value you are looking for in Column A of the worksheet. If the value is in some other column you will need to modify the FindValue function to reflect the column in question.

    The macro saves the attachment to a temporary file, examines it to see if it contains the value you seek and if it does it pops up a message. If it is not present the file is delete from the folder (not from the message).

    The macro looks for only one value, but if you wish to look for several values then you could assemble them in an array and loop through them.

    Option Explicit

    Sub CheckAttachments(olItem As MailItem)
    Const strPath As String = "C:\Path\" 'The path to save the workbook
    Const strFindText as String = "The value you want to find"
    Dim strFilename As String
    Dim olAttach As Attachment
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim bXStarted As Boolean
    Dim bFound As Boolean
        If olItem.Attachments.Count > 0 Then
            For Each olAttach In olItem.Attachments
                If Right(LCase(olAttach.Filename), 3) = "xls" Then
                    strFilename = strPath & Format(olItem.ReceivedTime, "yyyymmdd-HHMMSS") & _
                                  Chr(32) & olAttach.Filename
                    olAttach.SaveAsFile strFilename
                    On Error Resume Next
                    Set xlApp = GetObject(, "Excel.Application")
                    If Err <> 0 Then
                        Application.StatusBar = "Please wait while Excel source is opened ... "
                        Set xlApp = CreateObject("Excel.Application")
                        bXStarted = True
                    End If
                    On Error GoTo 0
                    'Open the workbook to read the data
                    Set xlWB = xlApp.Workbooks.Open(strFilename)
                    Set xlSheet = xlWB.Sheets("Sheet1")

                    If FindValue(strFindText, xlSheet) Then
                        MsgBox "Value found in " & strFilename
                        bFound = True
                    End If
                    xlWB.Close 0
                    If bXStarted Then xlApp.Quit
                    If Not bFound Then Kill strFilename
                    Exit For
                End If
            Next olAttach
        End If
    End Sub

    Function FindValue(FindString As String, iSheet As Object) As Boolean
    Dim Rng As Object
        If Trim(FindString) <> "" Then
            With iSheet.Range("A:A")
                Set Rng = .Find(What:=FindString, _
                                After:=.Cells(.Cells.Count), _
                                LookIn:=-4163, _
                                LookAt:=1, _
                                SearchOrder:=1, _
                                SearchDirection:=1, _
                                MatchCase:=False)
                If Not Rng Is Nothing Then
                    FindValue = True
                Else
                    FindValue = False
                End If
            End With
        End If
    End Function

    Sub Test()
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    CheckAttachments olMsg
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com


    • Edited by Graham MayorMVP Saturday, August 17, 2013 2:09 PM
    • Marked as answer by Shane Ry Monday, August 19, 2013 3:07 AM
    Saturday, August 17, 2013 2:08 PM
  • Thanks, I'm looking forward to trying this out Monday.  The only other feature I'll be trying to figure out is how to build an array from the values I want to find by pulling those in from an Excel file that's not necessarily open all the time. I've got a lot to learn, and this is a great start.
    Sunday, August 18, 2013 5:30 AM