Outlook VBA help please - Automate and Bcc based on word in subject line

[pk247]

Hi All,

I hope you are well and can help me with a task I'd like to automate for myself (mainly because it's started to get really annoying to do manually...)

I have some vba skills in excel and word but not so much in Outlook but I imagine this is possible.

The request which I'm hoping someone can help with is:

> With any New / Reply / Forward emails
> In email subject line I type a particular word e.g. WORD7654321 (spaces at beginning and end so nothing will tack on to it)
> Within the vba code I have a long list of "WORDS" combined with numbers like the one in the subject line and when I click on send if WORD7654321 is found in the list then automatically convert that word into email format and Bcc it e.g. WORD7654321email@domain_name.com - it will always be this format: & "email@domain_name.com" (it's a public folder repository email address where we must file all emails pertaining to WORD7654321)

I hope this make sense and I hope this is something that one of the Outlook coders can help with? Or guide me in the right direction with snippets of help?

Thanks so much and if you need me to clarify anything please let me know.

Cheers :beerchug:

Paul, Ireland

[gmayor]

How you handle the list of words rather depends on how many of them there are to check, but the following should do the trick, provided the list is not too long.


Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'Graham Mayor 05 November 2015
'Macro goes in the 'ThisOutlookSession' module
'A process to add a BCC to messages that match a certain criteria.
Const strWords As String = "WORD7654321|Another_Word|A_Third_etc" 'The 'words' to match each separated by "|"
Dim objRecip As Outlook.Recipient
Dim strBcc As String
Dim strMsg As String
Dim iResult As Integer
Dim vFind As Variant
Dim i As Long
On Error Resume Next
'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 = LBound(vFind) To UBound(vFind)
'If the word is in the message subject
If InStr(1, .Subject, vFind(i)) > 0 Then
strBcc = vFind(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

[pk247]

Dear Graham,

Yet again you help me save time by automating daily steps :) Thank you!

I googled for a limit to Split in part of your code:


vFind = Split(strWords, "|")

Ideally I would like to use a list of around 500 but I imagine that's too excessive so I can just add (or edit) to the "strWords" list manually each time I work on a new project.

Thank you so much!


Paul, Ireland :beerchug:

PS I've seen threads marked as [solved] but I can't see where to do that. I'll have a hunt but if anyone can advise I'd be grateful.

[pk247]

Found it :)

[gmayor]

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

[pk247]

Thank you so much Graham Mayor! This works perfectly and without any time delays! :)

I never knew you could perform SQL queries on sheets in Excel. I wish I had known about that years ago instead of writing code to open other workbooks then copy paste...

I'm learning loads of tips from you Graham and must say you are extremely helpful.

Thank you again and again!

Cheers :beerchug:


Paul, Ireland