Creating VBA-Macro for new custom message

[primofamilia]

Currently I am trying to understand how to build a custom macro-button into our Outlook 2010 / Outlook 2013 / Outlook 2016 enviroment.

What I want to achive:
When I get an email I want to be able to mark it and then click the Macro-icon of this script, and it should do the following:
Create an new email
Set the recipient in the email to a pre-defined e-mail adress
Set an pre-defined subject
Attach the marked email as an attachment (cannot be an forwarded email)
Send the email automatically

A bonus feature would be if I could mark multiple emails also when that occurs, and do the same thing with all the marked emails as attachments.
Sending them all in the same email is OK in that case.

Anyone got a clue on how I can achive this?

[gmayor]

The following macro will do all of that. Ensure that you change the three lines at the top for the fixed values before running the macro.

Option Explicit
Sub SendOnMessageasAttachment()
Dim olItem As Outlook.MailItem
Dim olOutMail As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object

Const sAddr As String = "someone@somewhere.com" ' the recipient
Const sSubj As String = "This is the message subject"
Const sText As String = "This is the covering message text"

If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If

Set olOutMail = CreateItem(olMailItem)
With olOutMail
.To = sAddr
.subject = sSubj
For Each olItem In Application.ActiveExplorer.Selection
.Attachments.Add olItem
Next olItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
oRng.Text = sText
.Display 'This line essential
'.Send 'Remove the apostrophe from the start of the line after testing.
End With
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
lbl_Exit:
Set olItem = Nothing
Set olOutMail = Nothing
Exit Sub
End Sub

[primofamilia]

Nice! Faster than ever - and 100% correct!! I'm impressed!

Just a question, if I would like the Subject in the email looking something like this:
This is the message subject <date>

And where date should be "today's" date... how can I add that?

[gmayor]

Change the following line

.subject = sSubj
to

.subject = sSubj & " <" & Format(Date, "Short Date") & ">"

[primofamilia]

Thank you very much gmayor!! :) Works 100%