Search code examples
vbaoutlookemail-attachments

Save an Excel file which contains a string from Outlook2007


Im newbiee in VBA, so i need a little help.

My goal is make an Outlook rule, but i have a problem:

I want to save one excel (xlsx) file from my Outlook Inbox to my PC. But only the file which contains (in spreadsheet) a string. But it saves (or not saving anything) the last excel file.. (not checking for MYSTRING)

Using this code:

Option Explicit

Sub CheckAttachments(olItem As MailItem)

Const strPath As String = "C:\Users\PC2\Documents\Temp_attachs\" 
Const strFindText As String = "Completed"
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), 4) = "xlsx" 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:J")
         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

Solution

  • I think I found your Problem:

    You have used Exit For in your For Loop only. So only after scanning 1st file, loop is exited.

    You need to remove the Exit For and then your code will work smoothly.

    Option Explicit
    
    Sub CheckAttachments(olItem As MailItem)
    
    Const strPath As String = "C:\Users\PC2\Documents\Temp_attachs\" 
    Const strFindText As String = "Completed"
    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), 4) = "xlsx" 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
    
             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:J")
             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