VBA Copy Email as .MSG to New Email - vba

Question

I am new to using VBA and I've looked around trying to find a solution. I don't know if this is even possible but I'm going to try and see if anyone can come up with any ideas.
So when you go into Outlook and you right click on an email, you can select copy. When you create a new email and paste the email, the copied email gets attached as a .msg as an attached file.
I am trying to replicate this process. Right now my process is
Find email
InStr(olMail.Subject, "SUBJECT") <> 0
Display email
olMail.Display
Copy body and set text to strPaste
Buf.SetText(OlMail.Body)
Buf.PutInClipBoard
strPaste = Buf.GetText(1)
Create new email
MailItem = OlApp.CreateItem(0)
Paste body
.Body = strPaste
This works but it isn't as clean because there are other things that are going into a message and it would be better for the copied email to be attached to an email instead of copying the body text.
I also don't want to save the email as an .msg and then attach it because other people will be using the macro and it would be quite tedious to change the path of where the email gets saved for every individual.
Any suggestions would be great!

Answer 1

So when you go into Outlook and you right click on an email, you can select copy. When you create a new email and paste the email, the copied email gets attached as a .msg as an attached file.
I am trying to replicate this process.
When forwarding MailItem as Attachment, use olEmbeddeditem
Which the Outlook message format file (.msg) is a copy of the original message to the new message.
Example in vba would be
Option Explicit
Sub Example()
'// Declare variables
Dim Msg As Outlook.MailItem
Dim Item As Outlook.MailItem
' Select Item
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox ("No Item selected")
Exit Sub
End If
For Each Item In Application.ActiveExplorer.Selection
Set Msg = Application.CreateItem(olMailItem)
With Msg
.Attachments.Add Item, olEmbeddeditem ' Attch Selected email
.Display
End With
Next
'// Clean up
Set Item = Nothing
Set Msg = Nothing
End Sub
Select the Email that you would like to copy as .msg to new Email, then run the code