need email content copied

[barcon]

Office 2000
I need to copy/get the message portion of a group of emails and paste/insert them into Word seqentially so that I can lose the headers and also control where a row breaks for printing. The message is embedded HTML which pastes as 4 tables per message into Word. The emails are created by a proprietary program (Eclipse).

The first roadblock I've run into is I can't copy the message body in order to paste it. I can cycle through the inbox and display each message but that's it. Manually selecting and copying is OK, but I can't seem to do it by VBA. I have looked through Help but don't find any clues. Can it be done?

I tried using Word as my email editor and forwarding the email so I would get the tables into Word but I still can't figure out how to access the message body.

Any help is appreciated. I have never used code in Outlook before.

Barbara

 

[DomFino]

Barbara,
I don't know if this will help but here goes. I use the following code to copy all of my email and attachments to a folder. Then I have full access to all the documents using Office.

What you do is copy this code to a macro in Outlook. Then go to the folder you want to copy email from. Highlight one or two or all the email in the folder and run the macro. I find that it works great.

I did not come up with this code. I found it on the Internet and for the life of me cannot remember where or who should receive credit.
Dom

Public Sub GetMails()

' extract the selected mail into .doc format

Printfile

' extract attachments from selected mail

SaveAttached

MsgBox "Email backups have completed."

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing

End Sub

Public Function Printfile()

Dim objMessage As Object
Dim oiMail As MailItem
Dim strSubj As String
Dim objSelection As Outlook.Selection
Dim objOL As Outlook.Application
Dim i As Long
Dim fol As String

On Error Resume Next
Call MakeFolder
fol = "c:\Documents and Settings\" & fOSUserName & "\My Documents\Saved_Email\" & Format(Date, "mmddyyyy")

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
For Each objMessage In objSelection
Set oiMail = objMessage

oimailsubj = oiMail.Subject 'Subject
oimailsubj1 = RemoveChars(oiMail.Subject)
oiMailbody = oiMail.Body 'Body
oiMailsname = oiMail.SenderName 'Sender Name
oiMailsize = oiMail.Size 'Mail Size
oiMailattach = oiMail.Attachments.Count 'Attachment count
If IsEmpty(oiMailattach) Or oiMailattach = 0 Then
oiMailattach = "no"
Else
oiMailattach = "yes"

For iCtr = 1 To oiMail.Attachments.Count
oiMailattachName = oiMail.Attachments.Item(iCtr).FileName
Next iCtr
End If

oiMailrtime = oiMail.ReceivedTime 'Received Time
'This generates a new text file each time it is run. To keep adding to the text file


Open fol & "\" & oimailsubj1 & ".doc" For Output As #1
Print #1, "Sender : " & oiMailsname
Print #1, "To : " & oiMail.To
Print #1, "Subject : " & oimailsubj
Print #1, "Cc : " & oiMail.CC
Print #1, "Body : " & oiMailbody
Print #1, "Size : " & oiMailsize
Print #1, "Attachment : " & oiMailattach
Print #1, "Attachment file name : " & oiMailattachName
Print #1, "Received on : " & oiMailrtime
Print #1, vbCrLf & vbCrLf
Close #1

Next

End Function

Function SaveAttached()

Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolder As String
Dim fol As String


On Error Resume Next
fol = "c:\Documents and Settings\" & fOSUserName & "\My Documents\Saved_Email\" & Format(Date, "mmddyyyy")

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' Get the destination folder.
strFolder = fol & "\"
' Check each selected item for attachments.
' If attachments exist, save them to the specified folder
For Each objMsg In objSelection
' save attachments from mail items.
If objMsg.Class = olMail Then

' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then

' We need to use a count down loop for
' removing items from a collection. Otherwise,
' the loop counter gets confused and only every
' other item is removed.

For i = lngCount To 1 Step -1
' Save attachment from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Specified folder.
strFile = strFolder & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
End If
Next

End Function

Function RemoveChars(Text As String) As String
Dim X As Byte
Const Unwanted = "\/?*.:<>" 'add other characters if needed
RemoveChars = Text
For X = 1 To Len(Unwanted)
RemoveChars = Replace(RemoveChars, Mid(Unwanted, X, 1), "")
Next
End Function

Function fOSUserName() As String
On Error GoTo fOSUserName_Err

Dim lngLen As Long, lngX As Long
Dim strUserName As String

strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)

If lngX <> 0 Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = ""
End If


fOSUserName_Exit:
Exit Function

fOSUserName_Err:
MsgBox Error$
Resume fOSUserName_Exit
End Function

Public Function MakeFolder()
Dim fso
Dim fol As String
Dim fol1 As String

' change to match the folder path

fol = "c:\Documents and Settings\" & fOSUserName & "\My Documents\Saved_Email\" & Format(Date, "mmddyyyy")
fol1 = "c:\Documents and Settings\" & fOSUserName & "\My Documents\Saved_Email\"

Set fso = CreateObject("Scripting.FileSystemObject")

' creates the Saved_Email folder in my documents for the logged in user
If Not fso.FolderExists(fol1) Then
fso.CreateFolder (fol1)
End If
' creates the daily folder for the current days date from the system clock
If Not fso.FolderExists(fol) Then
fso.CreateFolder (fol)
End If

End Function
' ------------END OF CODE -------------

 

[barcon]

Thanks Dom. The code doesn't do what I need but I'm going to save it just the same because Outlook code looks so difficult in comparison to Excel.

I need an embedded HTML table to get into WOrd as a table. I got some advice to paste the html string and save as .htm then open or insert it but so far I havent' gotten it to work.

Oh well, at least there's manual copy/paste!
Thanks for responding.

Barbara