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
Reply With Quote
