Copying body text from email to word doc

[Paul]

Hi

I am trying to resuscitate some lost code someone wrote a few years back.

Basically, a colleague receives between 50 and 250 emails with specific
information in them which all go (or are copied) into a specific outlook
folder. I need to be able to extract the body text (only) of all messages in
this folder received each day and copy this text into one word document for
the day

Can anyone help or point me in the right direction?

many thanks in advance

Paul

 

[Steve Yandl]

Paul,

The sub below will look in a subfolder of the Inbox named "Jokes" and
extract those messages received since the start of the current day and type
the bodies of those messages into the current active document with a new
paragraph started between each text body. If your folder of interest is at
the same level as the Inbox rather than being a subfolder, you will need a
slight modification. Note that when you run this subroutine, you will get a
security warning asking for permission to let the routine extract info from
Outlook for a period of 1 minute (or you can select a longer time period)

___________________________________

Sub CollectMsgBodies()
Const olFolderInbox = 6

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolderIN = objNamespace.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolderIN.Folders("Jokes")

dtmTargetDate = Date

Set colItems = objFolder.Items
Set colFilteredItems = colItems.Restrict("[ReceivedTime] > '" &
dtmTargetDate & "'")


For I = 1 To colFilteredItems.Count
Selection.TypeText colFilteredItems(I).Body
Selection.TypeParagraph
Next I

End Sub
__________________________________

Steve

 

[Steve Yandl]

I see a line got broken in what I posted above. Try this

Sub CollectMsgBodies()
Const olFolderInbox = 6

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolderIN = objNamespace.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolderIN.Folders("Jokes")

dtmTargetDate = Date

Set colItems = objFolder.Items
Set colFilteredItems = colItems.Restrict("[ReceivedTime] > '" _
& dtmTargetDate & "'")


For I = 1 To colFilteredItems.Count
Selection.TypeText colFilteredItems(I).Body
Selection.TypeParagraph
Next I

End Sub

 

[Steve Yandl]

Here is a new and improved version of the subroutine. This one looks in the
subfolder of the Inbox folder named "jokes", pulls the body text from all
messages that were received yesterday and places them in a file that gets
saved as 20071028.doc and saved in the default save location which is
typically the "my Documents" folder.

______________________________________

Sub CollectMsgBodies()

Const olFolderInbox = 6

Dim myDoc As Word.Document

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolderIN = objNamespace.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolderIN.Folders("Jokes")

Set myDoc = Documents.Add
myDoc.Activate

dtmYester = Date
dtmOlder = Date - 1

strFileNm = Year(dtmOlder) & Month(dtmOlder) & Day(dtmOlder) & ".doc"

Set colItems = objFolder.Items
Set colFilteredItems = colItems.Restrict("[ReceivedTime] < '" _
& dtmYester & "' AND [ReceivedTime] > '" & dtmOlder & "'")


For I = 1 To colFilteredItems.Count
Selection.TypeText colFilteredItems(I).Body
Selection.TypeParagraph
Next I

myDoc.SaveAs strFileNm
myDoc.Close SaveChanges:=wdSaveChanges

End Sub
_______________________________________

Steve

 

[Paul]

Steve

thanks for your help - I'll try it out this morning

Paul

--
Paul at preeve dot plus dot com

Here is a new and improved version of the subroutine. This one looks in
the subfolder of the Inbox folder named "jokes", pulls the body text from
all messages that were received yesterday and places them in a file that
gets saved as 20071028.doc and saved in the default save location which is
typically the "my Documents" folder.

______________________________________

Sub CollectMsgBodies()

Const olFolderInbox = 6

Dim myDoc As Word.Document

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolderIN = objNamespace.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolderIN.Folders("Jokes")

Set myDoc = Documents.Add
myDoc.Activate

dtmYester = Date
dtmOlder = Date - 1

strFileNm = Year(dtmOlder) & Month(dtmOlder) & Day(dtmOlder) & ".doc"

Set colItems = objFolder.Items
Set colFilteredItems = colItems.Restrict("[ReceivedTime] < '" _
& dtmYester & "' AND [ReceivedTime] > '" & dtmOlder & "'")


For I = 1 To colFilteredItems.Count
Selection.TypeText colFilteredItems(I).Body
Selection.TypeParagraph
Next I

myDoc.SaveAs strFileNm
myDoc.Close SaveChanges:=wdSaveChanges

End Sub
_______________________________________

Steve

 

[Paul]

Hi Steve

No joy unfortunately - I think the "set colItems" is not doing anything as
it just creates a blank document and I remains at 1, but its not even
pulling the body text from 1 message. Unfortunately although I'm quite good
at excel code my word code is virtually non-existent! so I am not sure what
may need amending

regards

Paul

--
Paul at preeve dot plus dot com

Here is a new and improved version of the subroutine. This one looks in
the subfolder of the Inbox folder named "jokes", pulls the body text from
all messages that were received yesterday and places them in a file that
gets saved as 20071028.doc and saved in the default save location which is
typically the "my Documents" folder.

______________________________________

Sub CollectMsgBodies()

Const olFolderInbox = 6

Dim myDoc As Word.Document

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolderIN = objNamespace.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolderIN.Folders("Jokes")

Set myDoc = Documents.Add
myDoc.Activate

dtmYester = Date
dtmOlder = Date - 1

strFileNm = Year(dtmOlder) & Month(dtmOlder) & Day(dtmOlder) & ".doc"

Set colItems = objFolder.Items
Set colFilteredItems = colItems.Restrict("[ReceivedTime] < '" _
& dtmYester & "' AND [ReceivedTime] > '" & dtmOlder & "'")


For I = 1 To colFilteredItems.Count
Selection.TypeText colFilteredItems(I).Body
Selection.TypeParagraph
Next I

myDoc.SaveAs strFileNm
myDoc.Close SaveChanges:=wdSaveChanges

End Sub
_______________________________________

Steve

 

[Paul]

Hi Steve,

no joy unfortunately. I don't think the "Set colItems" is doing anything as
I remains as 1, but equally there is nothing pulled from the first message
either, it just creates a blank document and saves it. I don't get the
message about something trying to use Outlook either

unfortunately although I'm quite good with excel code my word code skills
are sadly lacking so I have no idea what to change

regards

Paul

--
Paul at preeve dot plus dot com

Here is a new and improved version of the subroutine. This one looks in
the subfolder of the Inbox folder named "jokes", pulls the body text from
all messages that were received yesterday and places them in a file that
gets saved as 20071028.doc and saved in the default save location which is
typically the "my Documents" folder.

______________________________________

Sub CollectMsgBodies()

Const olFolderInbox = 6

Dim myDoc As Word.Document

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolderIN = objNamespace.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolderIN.Folders("Jokes")

Set myDoc = Documents.Add
myDoc.Activate

dtmYester = Date
dtmOlder = Date - 1

strFileNm = Year(dtmOlder) & Month(dtmOlder) & Day(dtmOlder) & ".doc"

Set colItems = objFolder.Items
Set colFilteredItems = colItems.Restrict("[ReceivedTime] < '" _
& dtmYester & "' AND [ReceivedTime] > '" & dtmOlder & "'")


For I = 1 To colFilteredItems.Count
Selection.TypeText colFilteredItems(I).Body
Selection.TypeParagraph
Next I

myDoc.SaveAs strFileNm
myDoc.Close SaveChanges:=wdSaveChanges

End Sub
_______________________________________

Steve

 

[Russ]

Paul,
Did you at least change in the code; the name of the subfolder of the inbox
from "Jokes" to a name of the subfolder you have and you need copied?

Hi Steve,

no joy unfortunately. I don't think the "Set colItems" is doing anything as
I remains as 1, but equally there is nothing pulled from the first message
either, it just creates a blank document and saves it. I don't get the
message about something trying to use Outlook either

unfortunately although I'm quite good with excel code my word code skills
are sadly lacking so I have no idea what to change

regards

Paul

--
Paul at preeve dot plus dot com

Here is a new and improved version of the subroutine. This one looks in
the subfolder of the Inbox folder named "jokes", pulls the body text from
all messages that were received yesterday and places them in a file that
gets saved as 20071028.doc and saved in the default save location which is
typically the "my Documents" folder.

______________________________________

Sub CollectMsgBodies()

Const olFolderInbox = 6

Dim myDoc As Word.Document

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolderIN = objNamespace.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolderIN.Folders("Jokes")

Set myDoc = Documents.Add
myDoc.Activate

dtmYester = Date
dtmOlder = Date - 1

strFileNm = Year(dtmOlder) & Month(dtmOlder) & Day(dtmOlder) & ".doc"

Set colItems = objFolder.Items
Set colFilteredItems = colItems.Restrict("[ReceivedTime] < '" _
& dtmYester & "' AND [ReceivedTime] > '" & dtmOlder & "'")


For I = 1 To colFilteredItems.Count
Selection.TypeText colFilteredItems(I).Body
Selection.TypeParagraph
Next I

myDoc.SaveAs strFileNm
myDoc.Close SaveChanges:=wdSaveChanges

End Sub
_______________________________________

Steve

Hi

I am trying to resuscitate some lost code someone wrote a few years back.

Basically, a colleague receives between 50 and 250 emails with specific
information in them which all go (or are copied) into a specific outlook
folder. I need to be able to extract the body text (only) of all messages
in this folder received each day and copy this text into one word
document for the day

Can anyone help or point me in the right direction?

many thanks in advance

Paul