If you want a list of 500 words then make the list in Excel. Put the words all in the first column with a header row and without any empty rows and save it. Let's call it 'Word List.xlsx" Then use the following code to read the worksheet into an array and loop through the array to process the subject:
Option Explicit
Private Const strWorkbook As String = "C:\Path\Word List.xlsx" 'The full path to the word list file
Private Const strWorksheetName As String = "Sheet1"
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'Graham Mayor 06 November 2015
'Macro goes in the 'ThisOutlookSession' module
'A process to add a BCC to messages that match a certain criteria.
Dim objRecip As Outlook.Recipient
Dim strBcc As String
Dim strMsg As String
Dim iResult As Integer
Dim arr() As Variant
Dim i As Long
On Error Resume Next
'Read the worksheet into an array
arr = xlFillArray(strWorkbook, strWorksheetName)
'the default part of the address
strBcc = "email@domain_name.com"
'separate the 'words'
'vFind = Split(strWords, "|")
'Process the outgoing message
With Item
'check each 'word'
For i = 0 To UBound(arr, 2)
'If the word is in the message subject
If InStr(1, .Subject, arr(0, i)) > 0 Then
strBcc = arr(0, i) & strBcc
Set objRecip = .Recipients.Add(strBcc)
objRecip.Type = olBCC
If Not objRecip.Resolve Then
strMsg = "Could not resolve the Bcc recipient. " & _
"Do you want to send the message?"
iResult = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve Bcc")
If iResult = vbNo Then
Cancel = True
End If
End If
'add the BCC
'save the message
.Save
'and stop looking
Exit For
End If
Next i
End With
lbl_Exit:
Set objRecip = 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
Dim iCols 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