Copy texts from current email in Outlook to cells in Excel

[F_Ribeiro]

Hello everybody!

I want to create a macro that copies texts from the current email in Outlook and pastes it into cells in the row of a spreadsheet, as a manual procedure is laborious and repetitive. Something that is seemingly simple, and it should be.

I wrote the code below, but I can't figure out how to assign the current email as an item in VBA, I looked around and didn't quite understand how I can do it. Also, I would like to search for the texts that are in bold and then copy the ones directly below them, assigning those to specific column cells. I have attached the images to give an example of what I need.

For now that's all, the help would be very valuable for me to start working with Outlook and I would be very grateful.

Sub F_Ribeiro12()

Dim outApp As Outlook.Application
Dim outMapi As Outlook.MAPIFolder
Dim outMail As Outlook.MailItem
Dim outHTML As MSHTML.HTMLDocument

Dim WB As Workbook
Dim WS As Worksheet
Dim Mail As String
Dim inbox As String
Dim lastrow As Long

Set WB = Workbooks("Book1")
Set WS = Sheets("Sheet1")
WB.Activate
WS.Activate
lastrow = WS.Range("A" & Rows.Count).End(xlUp).Row

Mail = "some_mail_user@outlook.com"
inbox = "Inbox"

Set outMapi = outApp.GetNamespace("MAPI").Folders(pasta).Folders(subpasta)
Set outHTML = New MSHTML.HTMLDocument

End Sub

F. Ribeiro

 

[DanteAmor]

First check if you can get the information from your email. Then with another code you look for data and organize it as you wish.

Try the following to get the sender, the subject and the body of the mail to put on sheet1

Sub Get_Mail_Data()
  Dim olApp As Object     'Outlook.Application
  Dim objNS As Object     'Outlook.Namespace
  Dim olFolder As Object  'Outlook.MAPIFolder
  Dim itm As Object
  Dim sh As Worksheet
  Dim i As Long
  '
  Application.ScreenUpdating = False
  Set olApp = CreateObject("Outlook.Application")
  Set objNS = olApp.GetNamespace("MAPI")
  Set olFolder = objNS.GetDefaultFolder(6)  'The Inbox folder
  Set sh = ThisWorkbook.Sheets("Sheet1")
  
  sh.Range("A2:C" & Rows.Count).ClearContents
  On Error Resume Next
  i = 2
  For Each itm In olFolder.Items
    sh.Range("A" & i).Value = itm.SenderName
    sh.Range("B" & i).Value = itm.Subject
    sh.Range("C" & i).Value = itm.body
    i = i + 1
  Next
  
  sh.Range("A:C").WrapText = False
  Application.ScreenUpdating = True
End Sub

 

[F_Ribeiro]

First check if you can get the information from your email. Then with another code you look for data and organize it as you wish.

Try the following to get the sender, the subject and the body of the mail to put on sheet1

Sub Get_Mail_Data()
  Dim olApp As Object     'Outlook.Application
  Dim objNS As Object     'Outlook.Namespace
  Dim olFolder As Object  'Outlook.MAPIFolder
  Dim itm As Object
  Dim sh As Worksheet
  Dim i As Long
  '
  Application.ScreenUpdating = False
  Set olApp = CreateObject("Outlook.Application")
  Set objNS = olApp.GetNamespace("MAPI")
  Set olFolder = objNS.GetDefaultFolder(6)  'The Inbox folder
  Set sh = ThisWorkbook.Sheets("Sheet1")
 
  sh.Range("A2:C" & Rows.Count).ClearContents
  On Error Resume Next
  i = 2
  For Each itm In olFolder.Items
    sh.Range("A" & i).Value = itm.SenderName
    sh.Range("B" & i).Value = itm.Subject
    sh.Range("C" & i).Value = itm.body
    i = i + 1
  Next
 
  sh.Range("A:C").WrapText = False
  Application.ScreenUpdating = True
End Sub

Hello Dante! Thank you for helping me and... my apologies for the delay.


Well, the code works, that's fine considering I've never used Outlook with VBA. However, it would be really nice if I could assign these suggested values from a single email that was selected. I searched and I can't find something like that.

Thank you again. But would you know how to specify a selected email in the code, Dante?

No more, until next time.

Regards,


F. Ribeiro