Macro to automatically forward new emails with a string in subject to another address

[ostego]

Hi,

I have been working on a project, and have one last piece of the puzzle I need your help with.

Basically this element requires any email where the subject contains "apple" for example to be automatically forwarded as an attachment to another email address (which will always be the same address).

I have tried making rules in outlook that will look for inbound messages containing that, and forwarding, but for some reason this simply does not work (I am unsure why, but have tried on multiple accounts and computers, and it just won't work with our setup!)

I was wondering if it would be possible to write a macro script that works within outlook that would automatically pick up emails with "apples" in the subject and forward them on. Is this at all possible?

In the event that it isn't, we could probably just work with a macro button that would sit on the ribbon of every message that arrives in the inbox, and this process would forward the given email as an attachment to the specified email address.

If this could be automatic it would be so much better, but if it is simply not possible, the button process would work.

Could anybody PLEASE help me with this! I'm tearing my hair out; my VBA knowledge is quite limited and self taught, and for the rest of my processes I have pieced together existing bits of code on the web to get it to do as I need; but this just is beyond the complexity level that I can wrap my head around!

Thanks

[gmayor]

The following should do the trick. Either run the main script from a rule to process all incoming messages or run it from the test macro with a selected message.


Option Explicit

Sub TestMacro()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.item(1)
SendMessageAsAttachment olMsg
lbl_Exit:
Set olMsg = Nothing
Exit Sub
End Sub

Sub SendMessageAsAttachment(item As Outlook.MailItem)
Dim olOutMail As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim sList As String
Dim vCC As Variant
Dim i As Long
Const strMessage As String = "Message containing 'apple' in the subject" 'the covering message
Const strSubject As String = "apple"
Const sAddr As String = "you@somewhere.com" 'the address you want the message sending to
sList = ""
If InStr(1, LCase(item.Subject), strSubject) > 0 Then
Set olOutMail = CreateItem(olMailItem)
With olOutMail
.To = sAddr
.CC = ""
.BCC = ""
.Subject = item.Subject
.Attachments.Add item
.BodyFormat = olFormatHTML
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
oRng.Text = strMessage
.Display 'This line is required
'.sEnd 'Restore after testing
End With
End If
lbl_Exit:
Set olOutMail = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub