excel macro to copy the outlook mail body to a new excel workbook
 

I have written the macro code in excel, and from excel macro iam able to
DISPLAY the mail based on subject provided, now i need a macro code to copy
the body of displayed mail and paste it to a new excel workbook.

Here is my code....

Private strForwardTo As String

Sub subject_beginswith()

Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim myitem As Outlook.MailItem
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim objSearchFolder As Outlook.MAPIFolder
Dim Recipient As Outlook.Recipient
Dim CorrRecip As String
Dim item As Object
Dim Body

Dim mai As MailItem


Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set objSearchFolder = Inbox
i = 0

If Inbox.Items.Count = 0 Then
MsgBox "Inbox is Empty", vbInformation, "Nothing Found"
End If

For Each item In Inbox.Items
If Format(item.ReceivedTime, "DD/MM/YY") < Format(Date, "DD/MM/YY") Then
GoTo nextme
If item.Subject Like "Reminder to complete the 2008 Thomson Reuters
Employee*" Then
item.Display
' Workbooks.Add
'ActiveSheet.Paste
SendKeys "(^A)"

Exit Sub
End If
nextme:
Next

End Sub

excel macro to copy the outlook mail body to a new excel workbook
 

"Ranjit kurian" wrote:

I have written the macro code in excel, and from excel macro iam able to
DISPLAY the mail based on subject provided, now i need a macro code to copy
the body of displayed mail and paste it to a new excel workbook.

Here is my code....

Private strForwardTo As String

Sub subject_beginswith()

Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim myitem As Outlook.MailItem
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim objSearchFolder As Outlook.MAPIFolder
Dim Recipient As Outlook.Recipient
Dim CorrRecip As String
Dim item As Object
Dim Body

Dim mai As MailItem


Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set objSearchFolder = Inbox
i = 0

If Inbox.Items.Count = 0 Then
MsgBox "Inbox is Empty", vbInformation, "Nothing Found"
End If

For Each item In Inbox.Items
If Format(item.ReceivedTime, "DD/MM/YY") < Format(Date, "DD/MM/YY") Then
GoTo nextme
If item.Subject Like "Lock*" Then
item.Display
' Workbooks.Add
'ActiveSheet.Paste
SendKeys "(^A)"

Exit Sub
End If
nextme:
Next

End Sub