VBA Export Outlook. emails to Excel, only specific part of the body text

[gijsvancuijk]

Hi experts,

Here playing with "VBA Export Outlook emails to Excel" and found already nice macro on thist site, see below


















Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Long, j As Long

Dim body_text As String
Dim body_cell As Variant, bc As Variant

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("LEXIS NEXIS")

i = 1
j = 0
For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("From_date").Value Then
Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName

body_text = OutlookMail.Body
j = 0
If InStr(1, body_text, "*") > 0 Then
body_cell = Split(body_text, "*")
For Each bc In body_cell
If bc <> "" Then
Range("eMail_text").Offset(i, j).Value = bc
j = j + 1
End If
Next
Else
Range("eMail_text").Offset(i, 0).Value = body_text
End If

i = i + 1
End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub

 

[gijsvancuijk]

Hi experts,

Here playing with "VBA Export Outlook emails to Excel" and found already nice macro on thist site, see below. As normal its not just match my wishes, i want only a specific part from the body text, the part between two words "problem/issues" and "Status". The mail below seperate the text in the body between **** and **** and copied them in different cells. Already playing with it few hours but ................... i need some support.

THANKS,

Regards Gijs


-------------------------------------------------------------------------------------------------------------------------------------
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Long, j As Long

Dim body_text As String
Dim body_cell As Variant, bc As Variant

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("LEXIS NEXIS")

i = 1
j = 0
For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("From_date").Value Then
Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName

body_text = OutlookMail.Body
j = 0
If InStr(1, body_text, "*") > 0 Then
body_cell = Split(body_text, "*")
For Each bc In body_cell
If bc <> "" Then
Range("eMail_text").Offset(i, j).Value = bc
j = j + 1
End If
Next
Else
Range("eMail_text").Offset(i, 0).Value = body_text
End If

i = i + 1
End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub

 

[gijsvancuijk]

Hi experts,

Here playing with "VBA Export Outlook emails to Excel" and found already nice macro on thist site, see below


















Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Long, j As Long

Dim body_text As String
Dim body_cell As Variant, bc As Variant

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("LEXIS NEXIS")

i = 1
j = 0
For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("From_date").Value Then
Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName

body_text = OutlookMail.Body
j = 0
If InStr(1, body_text, "*") > 0 Then
body_cell = Split(body_text, "*")
For Each bc In body_cell
If bc <> "" Then
Range("eMail_text").Offset(i, j).Value = bc
j = j + 1
End If
Next
Else
Range("eMail_text").Offset(i, 0).Value = body_text
End If

i = i + 1
End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub

this one can be deleted, sorry, my bad