Save an Excel file which contains a string from Outlook2007 - vba

Question

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

Answer 1

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