Macro to send out email based on criteria via outlook

[MD011]

Good morning,

I'm not entirely sure if what I am after is possible however hopefully some sort of solution will be possible!

I am looking for a macro that can be run within an open email in outlook that will look for specific criteria and then email a specific recipient based on that criteria after matching it against information within an excel sheet.

The macro would look for the information from within an excel spreadsheet and match that against the information contained within the email and in turn send out a notification to specified recipients.

The criteria would be - Subject, String within attachment name and sender email.

I have attached an example of what the spreadsheet would look like, it contains the fields File Name Subject Sender Email Notification

13137

So for example if an email came in and had the necessary criteria that matched that line in the excel sheet, an email would then be sent out to the email address/addresses mentioned in the "Email Notification" column by pressing this macro.

The emails that would get sent out as notifications would all contain the same message, for testing purposes something like "Notification of email arrival" would do.

If you have any questions please let me know, thanks in advance for any help as it is greatly appreciated.

Thanks,

Matt

[gmayor]

What you ask is reasonably straightforward given the type of workbook you envisage. The macro is probably best run as a script from a rule to check the messages as they arrive, but you can run the TestMsg macro to both test and process individual messages. Change the path and worksheet name as appropriate. Select a message and run TestMsg.
The macro reads the named worksheet into an array. This is very fast in practice, as is the search. The values are then compared with the subject, sender and attachment. Anything that meets the criteria results in a raised message.



Option Explicit
Const strWorkbook As String = "C:\Path\Excel forum.xlsx" 'The path of the workbook
Const strSheet As String = "Sheet1" 'The name of the worksheet

Sub TestMsg()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
AutoReply olMsg
lbl_Exit:
Exit Sub
End Sub

Sub AutoReply(olMail As Outlook.MailItem)
Dim olReply As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim Arr() As Variant
Dim iCols As Long
Dim iRows As Long
Dim strName As String
Dim oAtt As Attachment
'load the worksheet into an array
Arr = xlFillArray(strWorkbook, strSheet)
With olMail
For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
'If column 2 (starting at column 0) contains the e-mail address of the message
If .SenderEmailAddress = Arr(2, iRows) Then
'If the subject value is in the message subject
If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
'process the attachments to the message
For Each oAtt In .Attachments
'If any attachment filename has the text in column 0
If InStr(1, oAtt.Filename, Arr(0, iRows)) > 0 Then
'Create a message
Set olReply = CreateItem(olMailItem)
With olReply
.Subject = Arr(1, iRows)
.To = Arr(3, iRows)
.BodyFormat = olFormatHTML
.Display
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
oRng.Text = "Notification of email arrival"
'.sEnd 'Restore after testing
End With
Exit For
End If
Next oAtt
End If
End If
Next iRows
End With
lbl_Exit:
Set olReply = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
strWorksheetName As String) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strWorksheetName = strWorksheetName & "$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function

[MD011]

Thanks very much for the reply. Unfortunately this doesn't seem to be working, I am pressing the macro but getting no response.

What I have been doing is opening an email up then pressing the macro, is this how it should be ran? Apologies for the questions however my knowledge is very low. Below are my column headers, do these need changing for example?



File Name
Subject
Sender
Email Notification

[gmayor]

The macro won't do anything if the message is not from the sender's e-mail address in the Excel list, OR the subject text doesn't contain the text (case sensitive) in the matching worksheet record, OR the attachment name (case sensitive) doesn't contain the text in the worksheet record. All three have to match for the macro to produce a response. Create a record in your data sheet that has the three items in the message you are testing and then test it.

[MD011]

Thanks again for the help it is much appreciated.

Is there any way to change the code so that it only looks for a specific string in the mentioned columns? So for example if an email came through with the subject "testing help" then i would just put "testing" in my column named "subject" instead of the full subject if that makes sense?

Or can i do that already by simply changing my entries in my excel sheet?

[gmayor]

You don't need to change anything to achieve that, as the macro already looks for the column text in the subject


If InStr(1, .Subject, Arr(1, iRows)) > 0 Then

Arr(1, iRows) is the data from the Subject column of the worksheet. If you have 'testing' in The column, it will match with 'testing help' in the message subject. It will not however match with 'Testing help'. If the subject may have mixed case, change the line to


If InStr(1, LCase(.Subject), Arr(1, iRows)) > 0 Then and ensure the worksheet column only has lower case entries.

[MD011]

Hi again, i unfortunately still have not been able to get this to function correctly.

Any further help will be appreciated as I am keen to get this up and running.

[gmayor]

What happens when you try? In what way is it not correct?

[MD011]

Nothing is happening, that is the problem, I can only imagine that perhaps something isn't setup correctly. I am ensuring that the File name, subject, sender are being met and have a valid email address in the email notification column.

I am then opening the email and running the macro manually. What could be causing this? Am i doing anything incorrect?

For example I sent myself an email with the following details:

Where I have put "" this is where i have entered the correct email adress.

File name - Testing.xlsx
Subject - test
Sender - ""

I then filled in a row in the sheet with the following info:

File name - Testing
Subject - test
Sender - ""
Email Notification - ""

Any help would be greatly appreciated.

[gmayor]

You can't use nul values in the worksheet. If there is no sender and no e-mail notification address the criteria are never met.
You need three pieces of information in the message to match and thus create a message to the address in email notification.
I changed the sender address in your original worksheet and it works as intended.

13385

[MD011]

Thanks again, the null values i entered "" were actually email addresses, it just wouldn't let me type the address into my message on the forum for some reason!

So in fact I am actually entering full email addresses however nothing is happening. The only thing I can think of is that the filepath may be wrong?

[gmayor]

The following must correctly match what you have:

Const strWorkbook As String = "C:\Path\Excel forum.xlsx" 'The path of the workbook
Const strSheet As String = "Sheet1" 'The name of the worksheet

[MD011]

Indeed i was under the impression that I had matched them correctly. I will triple check. Once again I appreciate the help.

[gmayor]

The bottom line is that the message you are processing must have the three items shown in the above illustration listed in the same row of your excel data sheet.
I would have expected an error message if the workbook/sheet data was wrong.

[MD011]

I'm pretty sure my criteria do match, i have tried multiple entries and switching things around but still no luck. I will keep trying but I am very confused! Is there any way I could be running it correctly? Also i have tried just putting a string from the email address in, is this acceptable?

[gmayor]

I really don't know what more I can tell you. Add a message box where shown below


With olMail
For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
'If column 2 (starting at column 0) contains the e-mail address of the message
'Add the following message box here
MsgBox .SenderEmailAddress & vbCr & Arr(2, iRows) & vbCr & vbCr & _
.Subject & vbCr & Arr(1, iRows) & vbCr & vbCr & _
Arr(0, iRows)


Select a message and run the TestMsg macro. Using your original worksheet, you should see something like

If the top pair are the same (unlike here); the word from the second line of the second pair is in the first line of the second pair and you have an attachment name with the word from last line, then the macro should create a message.

[MD011]

It is working now, thank you very much for the help, greatly appreciated.

[MD011]

Would it be possible to make the following small tweaks:

1. The messages send automatically so i dont need to manually click send.
2. The text inside the email states the Attachment, the sender address and the subject?

It would be perfect if that is possible :)

[gmayor]

If you remove the apostrophe from start of the line


'.sEnd 'Restore after testingit will send the messages automatically. I left that in for ease of testing.

The message body text is defined at the following line.


oRng.Text = "Notification of email arrival" You can change the value to reflect any message you require e.g


oRng.Text = "Notification of email arrival" & vbCr & vbCr & _
"Sender: " & .Sender & vbCr & _
"Subject: " & .Subject & vbCr & _
"Attachment: " & oAtt.FileName

[MD011]

Thank you very much. Unfortunately the below code does not seem to be working? The macro will no longer bring up an email:

oRng.Text = "Notification of email arrival" & vbCr & vbCr & _
"Sender: " & .Sender & vbCr & _
"Subject: " & .Subject & vbCr & _
"Attachment: " & oAtt.FileName

I simply replaced the original code - oRng.Text = "Notification of email arrival"

Is that how it should be done? Apologies for the basic questions here however my knowledge is very slim!

It now seems to be bringing the emails up HOWEVER it will not include the sender, subject or attachment info in the message.

[gmayor]

Sorry - my error :o:. It should be


oRng.Text = "Notification of email arrival" & vbCr & vbCr & _
"Sender: " & olMail.Sender & vbCr & _
"Subject: " & olMail.Subject & vbCr & _
"Attachment: " & oAtt.FileName

which replaces



oRng.Text = "Notification of email arrival"

[MD011]

Thank you so much, i REALLY appreciate all of the effort you have put into this, it is perfect :)

[MD011]

Sorry to be a pain but if possible there are a couple of minor things that I may need adding.

My situation - I monitor a variety of mailbox accounts.

Therefore if possible i need the following additions:

Need to be able to specify the email address the message is to be sent from in the code (This would be the same for each message) - The address needs to be

I also need to be able to specify a specific email signature to use (This would be the same for each message) - e.g. This message is brought to you courtesy of Matt

Thank you once again in advance for your kind assistance.

[gmayor]

Assuming these are not Exchange accounts then use the following. I have repeated all the required code. Put the sending address in place of someone@somewhere.com (and edit it out of your earlier message or Matt Williams will be inundated with junk mail). The code will use the default signature associated with that account, so create the signature in Outlook and associate it with the account.

Note it will now only work if there is an account called by the name in the strAcc constant. If not, no message will be created.



Option Explicit
Const strWorkbook As String = "C:\Path\Excel forum.xlsx" 'The path of the workbook
Const strSheet As String = "Sheet1" 'The name of the worksheet
Const strAcc As String = "someone@somewhere.com" 'The sending account

Sub TestMsg()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
AutoReply olMsg
lbl_Exit:
Exit Sub
End Sub

Sub AutoReply(olMail As Outlook.MailItem)
Dim olReply As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim oAccount As Outlook.Account
Dim wdDoc As Object
Dim oRng As Object
Dim Arr() As Variant
Dim iCols As Long
Dim iRows As Long
Dim strName As String
Dim oAtt As Attachment
'load the worksheet into an array
Arr = xlFillArray(strWorkbook, strSheet)
With olMail
For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
'If column 2 (starting at column 0) contains the e-mail address of the message
If .SenderEmailAddress = Arr(2, iRows) Then
'If the subject value is in the message subject
If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
'process the attachments to the message
For Each oAtt In .Attachments
'If any attachment filename has the text in column 0
If InStr(1, oAtt.FileName, Arr(0, iRows)) > 0 Then
For Each oAccount In Session.Accounts
If oAccount.DisplayName = strAcc Then
'Create a message
Set olReply = CreateItem(olMailItem)
With olReply
.Subject = Arr(1, iRows)
.To = Arr(3, iRows)
.SendUsingAccount = oAccount
.BodyFormat = olFormatHTML
.Display
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
oRng.Text = "Notification of email arrival" & vbCr & vbCr & _
"Sender: " & olMail.Sender & vbCr & _
"Subject: " & olMail.Subject & vbCr & _
"Attachment: " & oAtt.FileName
'.sEnd 'Restore after testing
End With
End If
Next oAccount
Exit For
End If
Next oAtt
End If
End If
Next iRows
End With
lbl_Exit:
Set olReply = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
strWorksheetName As String) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strWorksheetName = strWorksheetName & "$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function

[MD011]

Thanks very much again however there is a slight issue.

Firstly I have managed to specify which mailbox the message gets sent from by simply using ".SentOnBehalfOfName = (email address here)".

The problem I am having is getting the email to include one of the signatures that I have setup.

My situation is, i monitor a variety of mailboxes through one mail account if that makes sense? And i need one of the signatures to be assigned to one of these mailboxes which has a specific address.

[gmayor]

Did you try the code as posted?
Did you associate the signature with the account?

[MD011]

Thanks very much the only remaining problem now is that for some reason the messages are getting stuck in the outbox....I can send them normally but when using the macro they get stuck!

FYI - These are Microsoft Exchange Accounts

[gmayor]

The following macro should clear the Outbox


Sub SendAndReceiveAll()
Dim olNS As NameSpace
Dim olSyncs As SyncObjects
Dim olSync As SyncObject
Dim olItems As Items
Dim olItem As MailItem
Dim i As Long

Set olNS = Application.GetNamespace("MAPI")
Set olSyncs = olNS.SyncObjects
Set olItems = olNS.GetDefaultFolder(4).Items
For i = olItems.Count To 1 Step -1
Set olItem = olItems(i)
olItem.sEnd
DoEvents
Next i
For i = 1 To olSyncs.Count
Set olSync = olSyncs.Item(i)
olSync.Start
DoEvents
Next
CleanUp:
Set olItems = Nothing
Set olItem = Nothing
Set olNS = Nothing
Set olSyncs = Nothing
Set olSync = Nothing
lbl_Exit:
Exit Sub
End Sub

[MD011]

Still stuck in my outbox unfortunately :(. The email signature isnt a HUGE issue, i could use my default one that works okay, however ideally it woould be this custom one. Is there a some code that my be stopping it being sent?

[gmayor]

You can lose the signature if you change


Set oRng = wdDoc.Range(0, 0)
to

Set oRng = wdDoc.Range Then include the required signature in the text written to oRng

As for the blockage in the outbox. I have no idea why that is happening, but it is probably something to do with Exchange Server. As this is Exchange server you should be able to lose the lines


For Each oAccount In Session.Accounts
If oAccount.DisplayName = strAcc Then

and the corresponding

EndIf
Next oAccount
as you are using
.SentOnBehalfOfName = (email address here)

Thus


Sub AutoReply(olMail As Outlook.MailItem)
Dim olReply As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim Arr() As Variant
Dim iCols As Long
Dim iRows As Long
Dim strName As String
Dim oAtt As Attachment
'load the worksheet into an array
Arr = xlFillArray(strWorkbook, strSheet)
With olMail
For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
'If column 2 (starting at column 0) contains the e-mail address of the message
If .SenderEmailAddress = Arr(2, iRows) Then
'If the subject value is in the message subject
If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
'process the attachments to the message
For Each oAtt In .Attachments
'If any attachment filename has the text in column 0
If InStr(1, oAtt.FileName, Arr(0, iRows)) > 0 Then
'Create a message
Set olReply = CreateItem(olMailItem)
With olReply
.Subject = Arr(1, iRows)
.To = Arr(3, iRows)
.SentOnBehalfOfName = "someone@somewhere.com"
.BodyFormat = olFormatHTML
.Display
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
oRng.Text = "Notification of email arrival" & vbCr & vbCr & _
"Sender: " & olMail.Sender & vbCr & _
"Subject: " & olMail.Subject & vbCr & _
"Attachment: " & oAtt.FileName & vbCr & vbCr & _
"This message is brought to you courtesy of Matt"
'.sEnd 'Restore after testing
End With
Exit For
End If
Next oAtt
End If
End If
Next iRows
End With
lbl_Exit:
Set olReply = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub

[MD011]

Ok that seems perfect, thank you so much, it is REALLY appreciated :D

[John87]

What you ask is reasonably straightforward given the type of workbook you envisage. The macro is probably best run as a script from a rule to check the messages as they arrive, but you can run the TestMsg macro to both test and process individual messages. Change the path and worksheet name as appropriate. Select a message and run TestMsg.
The macro reads the named worksheet into an array. This is very fast in practice, as is the search. The values are then compared with the subject, sender and attachment. Anything that meets the criteria results in a raised message.



Option Explicit
Const strWorkbook As String = "C:\Path\Excel forum.xlsx" 'The path of the workbook
Const strSheet As String = "Sheet1" 'The name of the worksheet

Sub TestMsg()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
AutoReply olMsg
lbl_Exit:
Exit Sub
End Sub

Sub AutoReply(olMail As Outlook.MailItem)
Dim olReply As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim Arr() As Variant
Dim iCols As Long
Dim iRows As Long
Dim strName As String
Dim oAtt As Attachment
'load the worksheet into an array
Arr = xlFillArray(strWorkbook, strSheet)
With olMail
For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
'If column 2 (starting at column 0) contains the e-mail address of the message
If .SenderEmailAddress = Arr(2, iRows) Then
'If the subject value is in the message subject
If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
'process the attachments to the message
For Each oAtt In .Attachments
'If any attachment filename has the text in column 0
If InStr(1, oAtt.Filename, Arr(0, iRows)) > 0 Then
'Create a message
Set olReply = CreateItem(olMailItem)
With olReply
.Subject = Arr(1, iRows)
.To = Arr(3, iRows)
.BodyFormat = olFormatHTML
.Display
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
oRng.Text = "Notification of email arrival"
'.sEnd 'Restore after testing
End With
Exit For
End If
Next oAtt
End If
End If
Next iRows
End With
lbl_Exit:
Set olReply = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
strWorksheetName As String) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strWorksheetName = strWorksheetName & "$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function


Hi Graham,

This code looks like it could be adaptable to be used in a project I'm working on.

I can normally pull together and manipulate VB code in excel to get the result I want however when looking for Outlook code, the structure and how to form the commands I'm finding it difficult to grasp.

Effectively what I'm trying to do is export a list of e-mails into excel with sender, subject & time received (which includes the date). That part I've done and it works.

Then I will be comparing the matching up the data with another source of info that relates to the e-mails and in a fourth column a conclusion of what's to be done with the e-mail.

Before I go to the effort of the last bit I wanted to make sure there was a way to feed the conclusion back to outlook then either mark the e-mails as read and move them into a folder or set a flag to the e-mail.

I'm confident it's possible but I'm struggling to find enough info to put it together.

Any help would be greatly appreciated.

Cheers :biggrin:

John

[gmayor]

You will have to clarify - "I wanted to make sure there was a way to feed the conclusion back to outlook"

The incoming message here is olMail - Sub AutoReply(olMail As Outlook.MailItem).
Once you have control of the message, you can do what you want with it.
You can set it as read i.e. at the end of the With olMail section

.UnRead = False

or you can categorize it

.categories = "Processed"

or you can move it to an existing folder here a sub folder of inbox

.Move Session.GetDefaultFolder(olFolderInbox).folders("foldername")

or any combination of the threee.

[John87]

You will have to clarify - "I wanted to make sure there was a way to feed the conclusion back to outlook"

The incoming message here is olMail - Sub AutoReply(olMail As Outlook.MailItem).
Once you have control of the message, you can do what you want with it.
You can set it as read i.e. at the end of the With olMail section

.UnRead = False

or you can categorize it

.categories = "Processed"

or you can move it to an existing folder here a sub folder of inbox

.Move Session.GetDefaultFolder(olFolderInbox).folders("foldername")

or any combination of the threee.

Great, thanks. I'd always rather learn than just copy and paste, I'd come across .unread = True/False but wasn't sure of the context to use it in.

As mentioned I wanted to match the e-mails in outlook to the extracted data in excel then depending on the string in column 4 (of a set of 3 or 4) take the appropriate action above.

I understand roughly what this section of the code does(matches e-mails against the array before taking any action),I'll need to include another match against the received time, which parameters would I need to change in order for it to work from this 'If InStr(1, oAtt.Filename, Arr(0, iRows)) > 0 Then ', (if I repeat this to match with each of the different 'conclusion', which in effect will just be a text string)

What I'm not sure of is at which point I call .Unread = False or any other action in order for it to work but still go through the 'For Each' Loop'.:think:


With olMail
For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
'If column 2 (starting at column 0) contains the e-mail address of the message
If .SenderEmailAddress = Arr(2, iRows) Then
'If the subject value is in the message subject
If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
'process the attachments to the message
For Each oAtt In .Attachments
'If any attachment filename has the text in column 0
If InStr(1, oAtt.Filename, Arr(0, iRows)) > 0 Then


Thanks again

John

[gmayor]

You can issue the instruction at any time before End With closes the book on oMail. I guess before End If when the condition you are looking for is met

[John87]

Great OK,

So, I've had a look at it and come back with this, will this work?


Option ExplicitConst strWorkbook As String = "path" 'The path of the workbook
Const strSheet As String = "Sheet1" 'The name of the worksheet
Sub TestMsg()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
AutoReply olMsg
lbl_Exit:
Exit Sub
End Sub

Sub AutoReply(olMail As Outlook.MailItem)
Dim olReply As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim Arr() As Variant
Dim iCols As Long
Dim iRows As Long
Dim strName As String
'load the worksheet into an array
Arr = xlFillArray(strWorkbook, strSheet)
With olMail
For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
'If column 2 (starting at column 0) contains the e-mail address of the message
If .SenderEmailAddress = Arr(2, iRows) Then
'If the subject value is in the message subject
If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
If InStr(1, .ReceivedTime, Arr(1, iRows)) > 0 Then
'If the received time is in the message subject
If InStr(1, "Yes", Arr(1, iRows)) > 0 Then
'If The string above matches then mark the email as unread and move to 'Closed' folder
.UnRead = False
.Move
Session.Folders ("Closed")
Exit For
End If
Next oAtt
End If
End If
End If
Next iRows
End With
lbl_Exit:
Set olReply = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
strWorksheetName As String) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strWorksheetName = strWorksheetName & "$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function




If not where am I going wrong?

I think if anything I'm not entirely sure what the below is pointing at (specifically the number parameters)


If InStr(1, .ReceivedTime, Arr(1, iRows))


Thanks again

John

[gmayor]

In short, it won't work, but it might if you fix a few obvious errors


Option ExplicitConst strWorkbook As String = "path" 'The path of the workbook
should be on two lines

Option Explicit
Const strWorkbook As String = "path" 'The path of the workbook

.Move
Session.Folders ("Closed")
should be

.Move Session.Folders ("Closed")

Next oAttis an orphan command from a loop that no longer appears in the code and should be removed
'Arr' is a multidimensional array that is essentially a copy of your worksheet. The two numbered parameters in the brackets are column number and row number however the numbers start at 0 and not 1 as they are in the sheet.

[John87]

Thanks, everything so far has been really helpful!

I've been using 'Step Into' and messages to troubleshoot my way to this point :joy:.

So far everything works apart from


.Move Session.Folders("No Response")

So far this is how it looks:

Option ExplicitConst strWorkbook As String = "C:\Users\John\Desktop\OE.xlsx" 'The path of the workbook
Const strSheet As String = "Sheet1" 'The name of the worksheet
Sub MailFilter()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
MoveToFolder olMsg
lbl_Exit:
Exit Sub
End Sub

Sub MoveToFolder(olMail As Outlook.MailItem)
Dim olReply As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim Arr() As Variant
Dim iCols As Long
Dim iRows As Long
Dim strName As String
'load the worksheet into an array
Arr = xlFillArray(strWorkbook, strSheet)
With olMail
For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
'If column 2 (starting at column 0) contains the e-mail address of the message
If .SenderName = Arr(0, iRows) Then
'If the subject value is in the message subject
If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
If InStr(1, .ReceivedTime, Arr(2, iRows)) > 0 Then
'If the received time is in the message subject
If InStr(1, "Yes", Arr(3, iRows)) > 0 Then
'If The string above matches then mark the email as unread and move to 'No Response' folder
MsgBox "Match Found", vbOKOnly, "Match"
.UnRead = False
.Move Session.Folders("No Response")
Exit For
End If
End If
End If
End If
Next iRows
End With
lbl_Exit:
Set olReply = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
strWorksheetName As String) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strWorksheetName = strWorksheetName & "$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function

I've also come to realised that this only acts on the selected e-mail :crying:. How could I adapt this to apply this code to every message in the a selected folder (in my case an inbox)?

Huge thanks :biggrin:

John

[gmayor]

The code was intended to run from a rule as the messages arrive, however it is easy enough to process a folder

Sub ProcessFolder()
'Graham Mayor - http://www.gmayor.com - 03/11/2016
Dim olItem As Object
Dim olFolder As Folder
Set olFolder = Session.PickFolder 'select the folder
For Each olItem In olFolder.Items 'loop through the items
If TypeName(olItem) = "MailItem" Then
MoveToFolder olItem 'run the macro
End If
Exit For
Next olItem
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub

[John87]

That's awesome, I was really hoping that would be possible!:clap2:

I've tried a few different permutations of .Move and struggling to grasp the way it works

No matter how I put it together, I can't seem to get it to work :banghead:

How do you get that to Move the olMailItem to a parent folder similar to the below?


Dim Ns As Outlook.NameSpace


Set Ns = Application.GetNamespace("MAPI")


Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items

Ns.Move Items



Thanks again

John

[John87]

Hi, I've not been working on this in months and I've just come back to this project.

As above I've got this working to the point where it matches one mail item and marks it unread but still after fair bit of messing around haven't managed to get to the point where it will move the mail item to the "Closed" folder. I did try this but it didn't work. it might be worth saying that this is all working on a shared mailbox.

Also when I come to use the above code to process a whole folder, where abouts will that sit with the rest of the code?

Thanks again

John