Is there a VBA macro that can embed an email that is in the outlook Inbox into an Excel sheet?

[purinavin]

To all Excel Gurus!
Is there a vba macro that can run from Excel that will open up the Outlook Inbox so that a specific email can be selected and be embedded into a spreadsheet as an object? ie. When a user double clicks the embedded email icon in the sheet, then that particular email opens up. I know how to do this manually, but was wondering if anyone has a macro that does the same thing?

 

[cem123]

Hello Worf, Thank you so much for your help. I tried the code you shared and received some errors. I check how to fix it. And finally It is working now!!!
Please have the steps, and working code for your control and review.

1.Step : I changed the following folder as a folder in my desktop. (just change d:\test as a folder you choose)

before :
sn = "d:\test\" & sn & ".msg"

after :
sn = "C:\Users\Public\Desktop\vba\" & sn & ".msg"

2.Step: I received "Run Time Error 1004 Can not insert object" error when I run the code. And solution come up with changing Link:True as Link:False.

debug line is :

Set o = ActiveSheet.OLEObjects.Add(FileName:=sn, Link:=True, DisplayAsIcon:=False)

I changed as :

Set o = ActiveSheet.OLEObjects.Add(FileName:=sn, Link:=False, DisplayAsIcon:=False)

Dim sn$, olapp As Outlook.Application
' Excel module
Private Sub Embedder()
Dim olNameSpace As Namespace, olFolder  As MAPIFolder, olapp As Outlook.Application, _
o As OLEObject, ci As Object
Set olapp = New Outlook.Application
Set olNameSpace = olapp.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
On Error Resume Next
Set ci = olapp.ActiveInspector.CurrentItem                                          ' current message
If TypeName(ci) = "Nothing" Then Set ci = olapp.ActiveExplorer.Selection.Item(1)    ' or selected one
On Error GoTo 0
SaveMessageAsMsg ci
Set o = ActiveSheet.OLEObjects.Add(FileName:=sn, Link:=False, DisplayAsIcon:=False)
'Kill sn                                                                             ' delete file
Set olapp = Nothing
End Sub

Sub SaveMessageAsMsg(Item As MailItem)
'Enviro = CStr(Environ("USERPROFILE"))
sn = Item.Subject
ReplaceChars sn, "-"
sn = "C:\Users\Public\Desktop\vba\" & sn & ".msg"
Item.SaveAs sn, olMSG                       ' save to disk
End Sub

Private Sub ReplaceChars(ByVal nam$, sChr$)
  nam = Replace(nam, "'", sChr):  nam = Replace(nam, "*", sChr)
  nam = Replace(nam, "/", sChr):  nam = Replace(nam, "\", sChr)
  nam = Replace(nam, ":", sChr)
  nam = Replace(nam, "?", sChr)
  nam = Replace(nam, Chr(34), sChr)
  nam = Replace(nam, "<", sChr)
  nam = Replace(nam, ">", sChr)
  nam = Replace(nam, "|", sChr)
End Sub