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