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?

 

[Worf]

Hi

' Excel module
Dim sn$
Private Sub Embedder()
Dim olNameSpace As Namespace, olFolder  As MAPIFolder, olapp As Outlook.Application, o As OLEObject
Set olapp = New Outlook.Application
Set olNameSpace = olapp.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
SaveMessageAsMsg olFolder.Items(1)                                                  ' desired item
Set o = ActiveSheet.OLEObjects.Add(Filename:=sn, Link:=True, DisplayAsIcon:=False)
End Sub


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


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

 

[purinavin]

Hi Worf;
Good evening. I greatly appreciate your assistance with my request. Should I place this code into an Excel VBA module, or an Outlook VBA module?
I tried placing it in an Excel module, and hit run on the first macro, but got the following error:
"User defined type not defined" on the line of code: Sub SaveMessageAsMsg(Item As MailItem).

Any thoughts, or guidance on this would be most appreciated.

Thanks in advance,
Navin

 

[Worf]

• This code goes into an Excel module.
• Include a reference at VBE > Tools > References > Microsoft Outlook xx Object Library.

 

[purinavin]

Hi Worf;
Good afternoon.
This is amazing! I got it to work! Thank you for your support!
I noticed in the following line of code [SaveMessageAsMsg olFolder.Items(1) ]that the item value is is hard-coded as '1'. Is there any way that the macro can launch the Outlook Inbox and allow me to select whichever email I would like to have embedded into the Excel worksheet? Also, is there a line of code that you can share which would delete the email that gets copied to the desktop after it has been embedded into the worksheet?

Once again, your support is most deeply appreciated!
Thanks in advance,
Navin

 

[Worf]

Hi Navin

' Excel module
Dim sn$, olapp As Outlook.Application


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:=True, DisplayAsIcon:=False)
Kill sn                                                                             ' delete file
Set olapp = Nothing
End Sub


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

 

[cem123]

Hello,

I know that this topic is very old, But this is the only VBA code I have reached. So I am texting here If anyone can help me.
I have very basic VBA knowledge, and I don't know how to fix the error.
I have tried both codes above, and I received different errors in attached.

Is there anyone help me to fix the errors?

Thanks in advance.

 

[Worf]

Hello

The first error(sub not defined) is easy to fix, just paste that subroutine in your module.

Concerning the other one, which code line is highlighted in yellow when it occurs?

 

[cem123]

Hello

The first error(sub not defined) is easy to fix, just paste that subroutine in your module.

Concerning the other one, which code line is highlighted in yellow when it occurs?

Hello Worf,
Thanks to reply
I uploaded 2 VBA code debug lines.

The first error(sub not defined) is easy to fix, just paste that subroutine in your module. : I really dont know which part I should put it since I have basic VBA knowledge. Can you please fill the fixed code when you have time?

Regards,

 

[Worf]

Please try this version:

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:=True, 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 = "d:\test\" & 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